2. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 4/9/2019 7:02:00 AM Central Daylight Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.

2.1 Files compared

# Location File Last Modified
1 C:\AraxisMergeCompare\Pri_un\DG_53_952_V23_B7S1 DG_53_952_V23_B7S1.KID Wed Mar 20 18:19:26 2019 UTC
2 C:\AraxisMergeCompare\Pri_re\MHED P3 Healthshare 2.0-redacted\DG_53_952_V23_B7S1 DG_53_952_V23_B7S1.KID Mon Apr 8 20:07:02 2019 UTC

2.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 2 17958
Changed 1 2
Inserted 0 0
Removed 0 0

2.3 Comparison options

Whitespace
Character case Differences in character case are significant
Line endings Differences in line endings (CR and LF characters) are ignored
CR/LF characters Not shown in the comparison detail

2.4 Active regular expressions

No regular expressions were active.

2.5 Comparison detail

  1   KIDS Distr ibution sa ved on Mar  20, 2019@ 12:12:43
  2   DG*5.3*952   TEST v23  B7S1
  3   **KIDS**:D G*5.3*952^
  4  
  5   **INSTALL  NAME**
  6   DG*5.3*952
  7   "BLD",1025 7,0)
  8   DG*5.3*952 ^REGISTRAT ION^0^3190 320^y
  9   "BLD",1025 7,1,0)
  10   ^^4^4^3190 221^^^
  11   "BLD",1025 7,1,1,0)
  12   This patch  implement s the "EXP ANDED MH C ARE NON VE TERAN" as  a new
  13   "BLD",1025 7,1,2,0)
  14   eligibilit y code for  patient r egistratio n. It is u sed to ide ntify and
  15   "BLD",1025 7,1,3,0)
  16   track "oth er than ho norably di scharged"  service me mbers for  emergency
  17   "BLD",1025 7,1,4,0)
  18   mental hea lth servic es in the  VA.
  19   "BLD",1025 7,4,0)
  20   ^9.64PA^2^ 3
  21   "BLD",1025 7,4,2,0)
  22   2
  23   "BLD",1025 7,4,2,2,0)
  24   ^9.641^2^1
  25   "BLD",1025 7,4,2,2,2, 0)
  26   PATIENT  ( File-top l evel)
  27   "BLD",1025 7,4,2,2,2, 1,0)
  28   ^9.6411^.5 501^1
  29   "BLD",1025 7,4,2,2,2, 1,.5501,0)
  30   EXPANDED M H CARE TYP E
  31   "BLD",1025 7,4,2,222)
  32   y^n^p^^^^n ^^n
  33   "BLD",1025 7,4,2,224)
  34  
  35   "BLD",1025 7,4,33,0)
  36   33
  37   "BLD",1025 7,4,33,222 )
  38   y^y^f^^^^n
  39   "BLD",1025 7,4,33.1,0 )
  40   33.1
  41   "BLD",1025 7,4,33.1,2 22)
  42   y^y^f^^^^n
  43   "BLD",1025 7,4,"APDD" ,2,2)
  44  
  45   "BLD",1025 7,4,"APDD" ,2,2,.5501 )
  46  
  47   "BLD",1025 7,4,"B",2, 2)
  48  
  49   "BLD",1025 7,4,"B",33 ,33)
  50  
  51   "BLD",1025 7,4,"B",33 .1,33.1)
  52  
  53   "BLD",1025 7,6)
  54   10^
  55   "BLD",1025 7,6.3)
  56   68
  57   "BLD",1025 7,"INIT")
  58  
  59   "BLD",1025 7,"KRN",0)
  60   ^9.67PA^77 9.2^20
  61   "BLD",1025 7,"KRN",.4 ,0)
  62   .4
  63   "BLD",1025 7,"KRN",.4 ,"NM",0)
  64   ^9.68A^1^1
  65   "BLD",1025 7,"KRN",.4 ,"NM",1,0)
  66   DG OTH PRI NT TEMPLAT E    FILE  #33.1^33.1 ^0
  67   "BLD",1025 7,"KRN",.4 ,"NM","B", "DG OTH PR INT TEMPLA TE    FILE  #33.1",1)
  68  
  69   "BLD",1025 7,"KRN",.4 01,0)
  70   .401
  71   "BLD",1025 7,"KRN",.4 01,"NM",0)
  72   ^9.68A^^0
  73   "BLD",1025 7,"KRN",.4 02,0)
  74   .402
  75   "BLD",1025 7,"KRN",.4 02,"NM",0)
  76   ^9.68A^1^1
  77   "BLD",1025 7,"KRN",.4 02,"NM",1, 0)
  78   DG LOAD ED IT SCREEN  7    FILE  #2^2^0
  79   "BLD",1025 7,"KRN",.4 02,"NM","B ","DG LOAD  EDIT SCRE EN 7    FI LE #2",1)
  80  
  81   "BLD",1025 7,"KRN",.4 03,0)
  82   .403
  83   "BLD",1025 7,"KRN",.5 ,0)
  84   .5
  85   "BLD",1025 7,"KRN",.8 4,0)
  86   .84
  87   "BLD",1025 7,"KRN",3. 6,0)
  88   3.6
  89   "BLD",1025 7,"KRN",3. 8,0)
  90   3.8
  91   "BLD",1025 7,"KRN",9. 2,0)
  92   9.2
  93   "BLD",1025 7,"KRN",9. 8,0)
  94   9.8
  95   "BLD",1025 7,"KRN",9. 8,"NM",0)
  96   ^9.68A^19^ 16
  97   "BLD",1025 7,"KRN",9. 8,"NM",2,0 )
  98   DGOTHD^^0^ B71214411
  99   "BLD",1025 7,"KRN",9. 8,"NM",4,0 )
  100   DGOTHD1^^0 ^B61648572
  101   "BLD",1025 7,"KRN",9. 8,"NM",5,0 )
  102   DGOTHD2^^0 ^B18967603 0
  103   "BLD",1025 7,"KRN",9. 8,"NM",6,0 )
  104   DGLOCK1^^0 ^B21160237
  105   "BLD",1025 7,"KRN",9. 8,"NM",7,0 )
  106   DGOTHEDT^^ 0^B2076185 20
  107   "BLD",1025 7,"KRN",9. 8,"NM",8,0 )
  108   DGOTHRPT^^ 0^B1395042 06
  109   "BLD",1025 7,"KRN",9. 8,"NM",9,0 )
  110   DGOTHRP2^^ 0^B3766021 7
  111   "BLD",1025 7,"KRN",9. 8,"NM",10, 0)
  112   DGOTHRP1^^ 0^B6607221 0
  113   "BLD",1025 7,"KRN",9. 8,"NM",11, 0)
  114   DGOTHRP3^^ 0^B1997178 57
  115   "BLD",1025 7,"KRN",9. 8,"NM",12, 0)
  116   DGOTHRI^^0 ^B23726892 3
  117   "BLD",1025 7,"KRN",9. 8,"NM",13, 0)
  118   DGOTHRP4^^ 0^B2165806 1
  119   "BLD",1025 7,"KRN",9. 8,"NM",14, 0)
  120   DGOTHINQ^^ 0^B2237958 4
  121   "BLD",1025 7,"KRN",9. 8,"NM",15, 0)
  122   DGRP7^^0^B 21370530
  123   "BLD",1025 7,"KRN",9. 8,"NM",17, 0)
  124   DGRPD^^0^B 106142283
  125   "BLD",1025 7,"KRN",9. 8,"NM",18, 0)
  126   DGRPDB^^0^ B24321515
  127   "BLD",1025 7,"KRN",9. 8,"NM",19, 0)
  128   DGOTHUT1^^ 0^B2466375 5
  129   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGLOCK1" ,6)
  130  
  131   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGOTHD", 2)
  132  
  133   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGOTHD1" ,4)
  134  
  135   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGOTHD2" ,5)
  136  
  137   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGOTHEDT ",7)
  138  
  139   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGOTHINQ ",14)
  140  
  141   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGOTHRI" ,12)
  142  
  143   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGOTHRP1 ",10)
  144  
  145   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGOTHRP2 ",9)
  146  
  147   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGOTHRP3 ",11)
  148  
  149   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGOTHRP4 ",13)
  150  
  151   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGOTHRPT ",8)
  152  
  153   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGOTHUT1 ",19)
  154  
  155   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGRP7",1 5)
  156  
  157   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGRPD",1 7)
  158  
  159   "BLD",1025 7,"KRN",9. 8,"NM","B" ,"DGRPDB", 18)
  160  
  161   "BLD",1025 7,"KRN",19 ,0)
  162   19
  163   "BLD",1025 7,"KRN",19 ,"NM",0)
  164   ^9.68A^16^ 14
  165   "BLD",1025 7,"KRN",19 ,"NM",1,0)
  166   DG REGISTR ATION MENU ^^2
  167   "BLD",1025 7,"KRN",19 ,"NM",2,0)
  168   DG OTH MEN U^^0
  169   "BLD",1025 7,"KRN",19 ,"NM",5,0)
  170   DG OTH ADD  START DT  2ND 90^^0
  171   "BLD",1025 7,"KRN",19 ,"NM",6,0)
  172   DG OTH 2ND  PERIOD AU THBY EDIT^ ^0
  173   "BLD",1025 7,"KRN",19 ,"NM",7,0)
  174   DG OTH EDI T START DA TE^^0
  175   "BLD",1025 7,"KRN",19 ,"NM",8,0)
  176   DG OTH HIS TORY AUDIT  REPORT^^0
  177   "BLD",1025 7,"KRN",19 ,"NM",9,0)
  178   DG OTH ACT IVE 90-DAY  PERIOD^^0
  179   "BLD",1025 7,"KRN",19 ,"NM",10,0 )
  180   DG OTH EXC EPTION REP ORT^^0
  181   "BLD",1025 7,"KRN",19 ,"NM",11,0 )
  182   DG OTH REP ORTS MENU^ ^0
  183   "BLD",1025 7,"KRN",19 ,"NM",12,0 )
  184   DG OTH STA TISTICAL R EPORT^^0
  185   "BLD",1025 7,"KRN",19 ,"NM",13,0 )
  186   DG OTH STO P/REACTIVA TE CLOCK^^ 0
  187   "BLD",1025 7,"KRN",19 ,"NM",14,0 )
  188   DG OTH PAT IENT INQUI RY^^0
  189   "BLD",1025 7,"KRN",19 ,"NM",15,0 )
  190   DG OTH INA CT REPORT^ ^0
  191   "BLD",1025 7,"KRN",19 ,"NM",16,0 )
  192   DG OTH AUT H ADDITION AL 90 DAYS ^^0
  193   "BLD",1025 7,"KRN",19 ,"NM","B", "DG OTH 2N D PERIOD A UTHBY EDIT ",6)
  194  
  195   "BLD",1025 7,"KRN",19 ,"NM","B", "DG OTH AC TIVE 90-DA Y PERIOD", 9)
  196  
  197   "BLD",1025 7,"KRN",19 ,"NM","B", "DG OTH AD D START DT  2ND 90",5 )
  198  
  199   "BLD",1025 7,"KRN",19 ,"NM","B", "DG OTH AU TH ADDITIO NAL 90 DAY S",16)
  200  
  201   "BLD",1025 7,"KRN",19 ,"NM","B", "DG OTH ED IT START D ATE",7)
  202  
  203   "BLD",1025 7,"KRN",19 ,"NM","B", "DG OTH EX CEPTION RE PORT",10)
  204  
  205   "BLD",1025 7,"KRN",19 ,"NM","B", "DG OTH HI STORY AUDI T REPORT", 8)
  206  
  207   "BLD",1025 7,"KRN",19 ,"NM","B", "DG OTH IN ACT REPORT ",15)
  208  
  209   "BLD",1025 7,"KRN",19 ,"NM","B", "DG OTH ME NU",2)
  210  
  211   "BLD",1025 7,"KRN",19 ,"NM","B", "DG OTH PA TIENT INQU IRY",14)
  212  
  213   "BLD",1025 7,"KRN",19 ,"NM","B", "DG OTH RE PORTS MENU ",11)
  214  
  215   "BLD",1025 7,"KRN",19 ,"NM","B", "DG OTH ST ATISTICAL  REPORT",12 )
  216  
  217   "BLD",1025 7,"KRN",19 ,"NM","B", "DG OTH ST OP/REACTIV ATE CLOCK" ,13)
  218  
  219   "BLD",1025 7,"KRN",19 ,"NM","B", "DG REGIST RATION MEN U",1)
  220  
  221   "BLD",1025 7,"KRN",19 .1,0)
  222   19.1
  223   "BLD",1025 7,"KRN",19 .1,"NM",0)
  224   ^9.68A^1^1
  225   "BLD",1025 7,"KRN",19 .1,"NM",1, 0)
  226   DG OTH EDI T^^0
  227   "BLD",1025 7,"KRN",19 .1,"NM","B ","DG OTH  EDIT",1)
  228  
  229   "BLD",1025 7,"KRN",10 1,0)
  230   101
  231   "BLD",1025 7,"KRN",40 9.61,0)
  232   409.61
  233   "BLD",1025 7,"KRN",77 1,0)
  234   771
  235   "BLD",1025 7,"KRN",77 9.2,0)
  236   779.2
  237   "BLD",1025 7,"KRN",87 0,0)
  238   870
  239   "BLD",1025 7,"KRN",89 89.51,0)
  240   8989.51
  241   "BLD",1025 7,"KRN",89 89.52,0)
  242   8989.52
  243   "BLD",1025 7,"KRN",89 94,0)
  244   8994
  245   "BLD",1025 7,"KRN","B ",.4,.4)
  246  
  247   "BLD",1025 7,"KRN","B ",.401,.40 1)
  248  
  249   "BLD",1025 7,"KRN","B ",.402,.40 2)
  250  
  251   "BLD",1025 7,"KRN","B ",.403,.40 3)
  252  
  253   "BLD",1025 7,"KRN","B ",.5,.5)
  254  
  255   "BLD",1025 7,"KRN","B ",.84,.84)
  256  
  257   "BLD",1025 7,"KRN","B ",3.6,3.6)
  258  
  259   "BLD",1025 7,"KRN","B ",3.8,3.8)
  260  
  261   "BLD",1025 7,"KRN","B ",9.2,9.2)
  262  
  263   "BLD",1025 7,"KRN","B ",9.8,9.8)
  264  
  265   "BLD",1025 7,"KRN","B ",19,19)
  266  
  267   "BLD",1025 7,"KRN","B ",19.1,19. 1)
  268  
  269   "BLD",1025 7,"KRN","B ",101,101)
  270  
  271   "BLD",1025 7,"KRN","B ",409.61,4 09.61)
  272  
  273   "BLD",1025 7,"KRN","B ",771,771)
  274  
  275   "BLD",1025 7,"KRN","B ",779.2,77 9.2)
  276  
  277   "BLD",1025 7,"KRN","B ",870,870)
  278  
  279   "BLD",1025 7,"KRN","B ",8989.51, 8989.51)
  280  
  281   "BLD",1025 7,"KRN","B ",8989.52, 8989.52)
  282  
  283   "BLD",1025 7,"KRN","B ",8994,899 4)
  284  
  285   "BLD",1025 7,"QUES",0 )
  286   ^9.62^^
  287   "BLD",1025 7,"REQB",0 )
  288   ^9.611^3^3
  289   "BLD",1025 7,"REQB",1 ,0)
  290   DG*5.3*314 ^2
  291   "BLD",1025 7,"REQB",2 ,0)
  292   DG*5.3*842 ^2
  293   "BLD",1025 7,"REQB",3 ,0)
  294   DG*5.3*977 ^2
  295   "BLD",1025 7,"REQB"," B","DG*5.3 *314",1)
  296  
  297   "BLD",1025 7,"REQB"," B","DG*5.3 *842",2)
  298  
  299   "BLD",1025 7,"REQB"," B","DG*5.3 *977",3)
  300  
  301   "FIA",2)
  302   PATIENT
  303   "FIA",2,0)
  304   ^DPT(
  305   "FIA",2,0, 0)
  306   2I
  307   "FIA",2,0, 1)
  308   y^n^p^^^^n ^^n
  309   "FIA",2,0, 10)
  310  
  311   "FIA",2,0, 11)
  312  
  313   "FIA",2,0, "RLRO")
  314  
  315   "FIA",2,0, "VR")
  316   5.3^DG
  317   "FIA",2,2)
  318   1
  319   "FIA",2,2, .5501)
  320  
  321   "FIA",33)
  322   OTH ELIGIB ILITY CLOC K
  323   "FIA",33,0 )
  324   ^DGOTH(33,
  325   "FIA",33,0 ,0)
  326   33P
  327   "FIA",33,0 ,1)
  328   y^y^f^^^^n
  329   "FIA",33,0 ,10)
  330  
  331   "FIA",33,0 ,11)
  332  
  333   "FIA",33,0 ,"RLRO")
  334  
  335   "FIA",33,0 ,"VR")
  336   5.3^DG
  337   "FIA",33,3 3)
  338   0
  339   "FIA",33,3 3.01)
  340   0
  341   "FIA",33,3 3.02)
  342   0
  343   "FIA",33,3 3.11)
  344   0
  345   "FIA",33.1 )
  346   OTH CLOCK  HISTORY
  347   "FIA",33.1 ,0)
  348   ^DGOTH(33. 1,
  349   "FIA",33.1 ,0,0)
  350   33.1P
  351   "FIA",33.1 ,0,1)
  352   y^y^f^^^^n
  353   "FIA",33.1 ,0,10)
  354  
  355   "FIA",33.1 ,0,11)
  356  
  357   "FIA",33.1 ,0,"RLRO")
  358  
  359   "FIA",33.1 ,0,"VR")
  360   5.3^DG
  361   "FIA",33.1 ,33.1)
  362   0
  363   "FIA",33.1 ,33.12)
  364   0
  365   "KRN",.4,2 630,-1)
  366   0^1
  367   "KRN",.4,2 630,0)
  368   DG OTH PRI NT TEMPLAT E^3190215. 1012^@^33. 1^^@^31903 20
  369   "KRN",.4,2 630,"DXS")
  370   3
  371   "KRN",.4,2 630,"DXS", 1,9)
  372   X DXS(1,9. 6) S X=$P( DIP(304),U ,9),DIP(40 4)=$G(X) S  X=6,DIP(4 05)=$G(X)  S X=9,X=$E (DIP(404), DIP(405),X ) S Y=X,X= DIP(403),X =X_Y_")",Y =X,X=DIP(1 02),X=X_Y  S D0=I(0,0 )
  373   "KRN",.4,2 630,"DXS", 1,9.2)
  374   S I(0,0)=$ G(D0),DIP( 1)=$S($D(^ DGOTH(33.1 ,D0,0)):^( 0),1:""),D 0=$P(DIP(1 ),U,1) S:' D0!'$D(^DG OTH(33,+D0 ,0)) D0=-1  S D0=D0 S  I(100,0)= $G(D0),DIP (101)=$S($ D(^DGOTH(3 3,D0,0)):^ (0),1:"")
  375   "KRN",.4,2 630,"DXS", 1,9.3)
  376   X DXS(1,9. 2) S X=$P( $G(^DPT(+$ P(DIP(101) ,U,1),0)), U)_"     ( ",DIP(102) =$G(X),D0= $P(DIP(1), U,1) S:'D0 !'$D(^DGOT H(33,+D0,0 )) D0=-1 S  D0=D0 S I (200,0)=$G (D0)
  377   "KRN",.4,2 630,"DXS", 1,9.4)
  378   X DXS(1,9. 3) S DIP(2 01)=$S($D( ^DGOTH(33, D0,0)):^(0 ),1:""),DI P(202)=$G( X),D0=$P(D IP(201),U, 1) S:'D0!' $D(^DPT(+D 0,0)) D0=- 1 S D0=D0  S I(300,0) =$G(D0)
  379   "KRN",.4,2 630,"DXS", 1,9.5)
  380   X DXS(1,9. 4) S DIP(3 04)=$S($D( ^DPT(D0,0) ):^(0),1:" "),DIP(301 )=$G(X),DI P(302)=$G( X),D0=$P(D IP(1),U,1)  S:'D0!'$D (^DGOTH(33 ,+D0,0)) D 0=-1 S D0= D0
  381   "KRN",.4,2 630,"DXS", 1,9.6)
  382   X DXS(1,9. 5) S DIP(4 01)=$S($D( ^DGOTH(33, D0,0)):^(0 ),1:"") S  X=$P($G(^D PT(+$P(DIP (401),U,1) ,0)),U),DI P(402)=$G( X) S X=1,X =$E(DIP(40 2),X),DIP( 403)=$G(X)
  383   "KRN",.4,2 630,"DXS", 2,9.2)
  384   S I(0,0)=$ G(D0),DIP( 1)=$S($D(^ DGOTH(33.1 ,D0,0)):^( 0),1:""),D 0=$P(DIP(1 ),U,1) S:' D0!'$D(^DG OTH(33,+D0 ,0)) D0=-1  S D0=D0 S  I(100,0)= $G(D0),DIP (101)=$S($ D(^DGOTH(3 3,D0,0)):^ (0),1:"")
  385   "KRN",.4,2 630,"DXS", 2,9.3)
  386   X DXS(2,9. 2) S DIP(1 02)=$G(X), D0=$P(DIP( 101),U,1)  S:'D0!'$D( ^DPT(+D0,0 )) D0=-1 S  D0=D0 S D IP(201)=$S ($D(^DPT(D 0,0)):^(0) ,1:"")
  387   "KRN",.4,2 630,"F",1)
  388   ""~"Patien t Name     :";X;"";C1 ~X DXS(1,9 ) W X K DI P;X;"";C21 ;Z;"OTH CL OCK_"      ("_OTH CLO CK:PATIENT :$E(OTH CL OCK,1)_$E( SSN,6,9)_" )""~
  389   "KRN",.4,2 630,"F",2)
  390   "Date of B irth   :"; X;"";C1~
  391   "KRN",.4,2 630,"F",3)
  392   N DIERR X  DXS(2,9.3)  S X=$$EXT ERNAL^DIDU (2,.03,"", $P(DIP(201 ),U,3)) S  D0=I(0,0)  W X K DIP; X;"";C21;Z ;"OTH CLOC K:PATIENT: DOB"~1,""; S~
  393   "KRN",.4,2 630,"F",4)
  394   1,"365 Day s Period : ";X;"";C1~ 1,.01;C19; ""~1,"90 D ays Period   :";X;""; C1~1,.02;C 20;""~1,"F ield Updat ed   :";X; "";C1~1,.0 3;C21;""~
  395   "KRN",.4,2 630,"F",5)
  396   1,"Previou s Value  : ";X;"";C1~
  397   "KRN",.4,2 630,"F",6)
  398   1,S DIP(1) =$S($D(^DG OTH(33.1,D 0,1,D1,0)) :^(0),1:"" ) S X=$P(D IP(1),U,4) ,X=$P(X,". ",1) S Y=X  D DT K DI P;C21;"";d ;L18;Z;"DA TE(PREVIOU S VALUE)"~
  399   "KRN",.4,2 630,"F",7)
  400   1,"New Val ue       : ";X;"";C1~
  401   "KRN",.4,2 630,"F",8)
  402   1,S DIP(1) =$S($D(^DG OTH(33.1,D 0,1,D1,0)) :^(0),1:"" ) S X=$P(D IP(1),U,5) ,X=$P(X,". ",1) S Y=X  D DT K DI P;C21;"";d ;L18;Z;"DA TE(NEW VAL UE)"~
  403   "KRN",.4,2 630,"F",9)
  404   1,"Edited  By       : ";X;"";C1~ 1,.06;C21; ""~1,"Edit ed Date/Ti me:";X;""; C1~1,.07;C 21;""~1,D  RSNMSG^DGO THRPT;X;"" ;Z;"D RSNM SG^DGOTHRP T"~
  405   "KRN",.4,2 630,"H")
  406   OTH CLOCK  HISTORY Li st
  407   "KRN",.402 ,1093,-1)
  408   0^1
  409   "KRN",.402 ,1093,0)
  410   DG LOAD ED IT SCREEN  7^3190304. 1104^^2^^^ 3190319
  411   "KRN",.402 ,1093,"%D" ,0)
  412   ^.4021^1^1 ^3110428^^ ^^
  413   "KRN",.402 ,1093,"%D" ,1,0)
  414   This templ ate is use d to enter /edit data  on regist ration scr een 7.
  415   "KRN",.402 ,1093,"DIA B",1,1,2.0 5,0)
  416   ALL
  417   "KRN",.402 ,1093,"DIA B",6,0,2,2 )
  418   PENSION AW ARD EFFECT IVE DATE// /"@"
  419   "KRN",.402 ,1093,"DIA B",7,0,2,4 )
  420   PENSION AW ARD REASON ///"@"
  421   "KRN",.402 ,1093,"DIA B",8,0,2,2 )
  422   PENSION AW ARD REASON ///"@"
  423   "KRN",.402 ,1093,"DR" ,1,2)
  424   S:DGDR'["7 01" Y="@70 2";391;D S C7^DGRPV;1 901;.301;S :X'="Y" Y= .293;.302; .3012;.305 ;I $P($G(^ DPT(DFN,.3 61)),U)="V " I $P($G( ^DPT(DFN,. 361)),U,3) ="H" S Y=" @293";.304 ;S:X'="Y"  Y=.293;.30 13;S Y=.29 3;@293;
  425   "KRN",.402 ,1093,"DR" ,1,2,1)
  426   W !,"No ed iting P&T  Data, Elig ibility re cord verif ied by HEC ";.293;S:' X Y=.313;. 292;.291;. 313;.314;@ 702;S:DGDR '["702" Y= "@703";.36 205;.36215 ;S:$P($G(^ DPT(DFN,.3 85)),U,11) ="Y" Y="@7 025";
  427   "KRN",.402 ,1093,"DR" ,1,2,2)
  428   S:($P($G(^ DPT(DFN,.3 85)),U,10) ="Y")&($P( $G(^DPT(DF N,.362)),U ,14)="N")  Y="@7025"; S:$P($G(^D PT(DFN,.38 5)),U,10)= "Y" Y="@70 22";.36235 ;I X="Y" S  Y="@7022" ;Q;.3851// /^S X="@"; Q;.3852/// ^S X="@";S  Y="@7026" ;@7022;
  429   "KRN",.402 ,1093,"DR" ,1,2,3)
  430   S:($P($G(^ DPT(DFN,.3 85)),U,10) '="Y") Y=" @7023";D E N^DDIOL("P ension Awa rd Date an d Pension  Award Reas on are edi table only  if VA Pen sion",""," !!");
  431   "KRN",.402 ,1093,"DR" ,1,2,4)
  432   D EN^DDIOL ("Indicato r is Yes a nd Pension  Award Rea son is not  'Original  Award'.   For any"," ","!");D E N^DDIOL("o ther assis tance, use  the HEC A lert proce ss.","","! ");@7023;. 3851;I X]" " S Y="@70 24";Q;.385 2///^S X=" @";S Y="@7 026";@7024 ;
  433   "KRN",.402 ,1093,"DR" ,1,2,5)
  434   .3852;I X= "" S Y="@7 026";I X=$ $GET1^DIQ( 2,DFN,.385 2,"I") S Y ="@7026";I  $$GET1^DI Q(27.18,X, .01,"E")'[ "Original  Award" D E N^DDIOL("O nly 'Origi nal Award'  may be en tered",,"! !") S Y="@ 7024";S Y= "@7026";@7 025;
  435   "KRN",.402 ,1093,"DR" ,1,2,6)
  436   D EN^DDIOL ("Pension  Award Date  and Pensi on Award R eason are  editable o nly if VA  Pension"," ","!!");D  EN^DDIOL(" Indicator  is Yes and  Pension A ward Reaso n is not ' Original A ward'.  Fo r any","", "!");
  437   "KRN",.402 ,1093,"DR" ,1,2,7)
  438   D EN^DDIOL ("other as sistance,  use the HE C Alert pr ocess.","" ,"!");@702 6;.3025;S: (X'="Y")&( $P($G(^DPT (DA,.362)) ,U,12,14)' ["Y") Y=.3 6265;.3629 5;.36265;S :X'="Y" Y= "@703";.36 26;@703;S: DGDR'["703 " Y="@704" ;.361;
  439   "KRN",.402 ,1093,"DR" ,1,2,8)
  440   D XPANDED^ DGOTHD1(DF N) S Y="@7 027";@7027 ;D AAC1^DG LOCK2 S:DG AAC(1)']""  Y=361;.30 9;361;.323 ;D ^DGYZOD S S:'DGODS  Y="@704"; 11500.02;1 1500.03;@7 04;S:DGDR' ["704" Y=" @99";.3731 ;@99;
  441   "KRN",.402 ,1093,"DR" ,2,2.0361)
  442   .01;
  443   "KRN",.402 ,1093,"DR" ,2,2.05)
  444   .01:.02
  445   "KRN",.402 ,1093,"ROU ")
  446   ^DGRPX7
  447   "KRN",.402 ,1093,"ROU OLD")
  448   DGRPX7
  449   "KRN",19,4 25,-1)
  450   2^1
  451   "KRN",19,4 25,0)
  452   DG REGISTR ATION MENU ^Registrat ion Menu^^ M^.5^^^^^^ ^114^^1^1
  453   "KRN",19,4 25,10,0)
  454   ^19.01PI^3 8^38
  455   "KRN",19,4 25,10,38,0 )
  456   14642^OTH
  457   "KRN",19,4 25,10,38," ^")
  458   DG OTH MEN U
  459   "KRN",19,4 25,"U")
  460   REGISTRATI ON MENU
  461   "KRN",19,1 4642,-1)
  462   0^2
  463   "KRN",19,1 4642,0)
  464   DG OTH MEN U^Other Th an Honorab le Patient s Menu^^M^ ^^^^^^^
  465   "KRN",19,1 4642,1,0)
  466   ^19.06^2^2 ^3190305^^ ^^
  467   "KRN",19,1 4642,1,1,0 )
  468   This menu  contains o ptions to  manage Oth er Than Ho norable st atus for
  469   "KRN",19,1 4642,1,2,0 )
  470   patients.
  471   "KRN",19,1 4642,10,0)
  472   ^19.01IP^8 ^8
  473   "KRN",19,1 4642,10,1, 0)
  474   14643^^1
  475   "KRN",19,1 4642,10,1, "^")
  476   DG OTH AUT H ADDITION AL 90 DAYS
  477   "KRN",19,1 4642,10,2, 0)
  478   14644^^2
  479   "KRN",19,1 4642,10,2, "^")
  480   DG OTH EDI T START DA TE
  481   "KRN",19,1 4642,10,4, 0)
  482   14645^^4
  483   "KRN",19,1 4642,10,4, "^")
  484   DG OTH 2ND  PERIOD AU THBY EDIT
  485   "KRN",19,1 4642,10,5, 0)
  486   14646^^3
  487   "KRN",19,1 4642,10,5, "^")
  488   DG OTH ADD  START DT  2ND 90
  489   "KRN",19,1 4642,10,6, 0)
  490   14648^^5
  491   "KRN",19,1 4642,10,6, "^")
  492   DG OTH REP ORTS MENU
  493   "KRN",19,1 4642,10,7, 0)
  494   14668^^6
  495   "KRN",19,1 4642,10,7, "^")
  496   DG OTH STO P/REACTIVA TE CLOCK
  497   "KRN",19,1 4642,10,8, 0)
  498   14671^^7
  499   "KRN",19,1 4642,10,8, "^")
  500   DG OTH PAT IENT INQUI RY
  501   "KRN",19,1 4642,99)
  502   65077,3794 4
  503   "KRN",19,1 4642,"U")
  504   OTHER THAN  HONORABLE  PATIENTS 
  505   "KRN",19,1 4643,-1)
  506   0^16
  507   "KRN",19,1 4643,0)
  508   DG OTH AUT H ADDITION AL 90 DAYS ^Start Add itional 90 -Days Peri od^^R^^^^^ ^^^
  509   "KRN",19,1 4643,1,0)
  510   ^^2^2^3190 314^
  511   "KRN",19,1 4643,1,1,0 )
  512   This menu  option is  used to st art and au thorize an  additiona l 90-Days 
  513   "KRN",19,1 4643,1,2,0 )
  514   period for  the selec ted patien t.
  515   "KRN",19,1 4643,25)
  516   AUTH90DS^D GOTHD
  517   "KRN",19,1 4643,"U")
  518   START ADDI TIONAL 90- DAYS PERIO
  519   "KRN",19,1 4644,-1)
  520   0^7
  521   "KRN",19,1 4644,0)
  522   DG OTH EDI T START DA TE^Edit 90 -Day Start  Date^^R^^ DG OTH EDI T^^^^^^
  523   "KRN",19,1 4644,1,0)
  524   ^19.06^2^2 ^3180412^^ ^^
  525   "KRN",19,1 4644,1,1,0 )
  526   Allow user  to edit t he start d ate for th e 1st or 2 nd 90-Day  period of 
  527   "KRN",19,1 4644,1,2,0 )
  528   care for t he Other T han Honora ble patien ts.
  529   "KRN",19,1 4644,10.1)
  530  
  531   "KRN",19,1 4644,25)
  532   ESTRTDT^DG OTHEDT
  533   "KRN",19,1 4644,"U")
  534   EDIT 90-DA Y START DA TE
  535   "KRN",19,1 4645,-1)
  536   0^6
  537   "KRN",19,1 4645,0)
  538   DG OTH 2ND  PERIOD AU THBY EDIT^ Update 'Au thorized b y', 2nd 90  days^^R^^ DG OTH EDI T^^^^^^
  539   "KRN",19,1 4645,1,0)
  540   ^19.06^1^1 ^3180405^^ ^
  541   "KRN",19,1 4645,1,1,0 )
  542   Allows a s upervisor  to edit th e "Authori zed by" fi eld for th e 2nd 90 d ay period  of care.
  543   "KRN",19,1 4645,25)
  544   EDAUTHBY^D GOTHD2
  545   "KRN",19,1 4645,"U")
  546   UPDATE 'AU THORIZED B Y', 2ND 90
  547   "KRN",19,1 4646,-1)
  548   0^5
  549   "KRN",19,1 4646,0)
  550   DG OTH ADD  START DT  2ND 90^Add  start dat e 2nd 90 d ays^^R^^^^ ^^^^
  551   "KRN",19,1 4646,1,0)
  552   ^19.06^1^1 ^3180409^^ ^
  553   "KRN",19,1 4646,1,1,0 )
  554   Edit the s tart date  of the 2nd  90 day pe riod of ca re
  555   "KRN",19,1 4646,25)
  556   EDSTDT^DGO THD2
  557   "KRN",19,1 4646,"U")
  558   ADD START  DATE 2ND 9 0 DAYS
  559   "KRN",19,1 4647,-1)
  560   0^8
  561   "KRN",19,1 4647,0)
  562   DG OTH HIS TORY AUDIT  REPORT^Pa tient OTH  Audit Hist ory Report ^^R^^^^^^^ ^
  563   "KRN",19,1 4647,1,0)
  564   ^^7^7^3190 305^
  565   "KRN",19,1 4647,1,1,0 )
  566   This optio n prints i nformation  stored in  the OTH C LOCK HISTO RY file 
  567   "KRN",19,1 4647,1,2,0 )
  568   (#33.1)
  569   "KRN",19,1 4647,1,3,0 )
  570    
  571   "KRN",19,1 4647,1,4,0 )
  572   The report  prints th e patient  name, last  four(4) d igits of t heir SSN,  365 
  573   "KRN",19,1 4647,1,5,0 )
  574   days perio d, 90 Days  period, t he field e dited, the  old value , the new
  575   "KRN",19,1 4647,1,6,0 )
  576   value, the  user who  made the c hange, and  date/time  the field  was edite d.
  577   "KRN",19,1 4647,1,7,0 )
  578   The right  margin for  this repo rt is 80.
  579   "KRN",19,1 4647,25)
  580   EN^DGOTHRP T
  581   "KRN",19,1 4647,60)
  582  
  583   "KRN",19,1 4647,63)
  584  
  585   "KRN",19,1 4647,64)
  586  
  587   "KRN",19,1 4647,67)
  588  
  589   "KRN",19,1 4647,99)
  590   64765,7683 9
  591   "KRN",19,1 4647,"U")
  592   PATIENT OT H AUDIT HI STORY REPO
  593   "KRN",19,1 4648,-1)
  594   0^11
  595   "KRN",19,1 4648,0)
  596   DG OTH REP ORTS MENU^ Other than  honorable  reports^^ M^^^^^^^^
  597   "KRN",19,1 4648,10,0)
  598   ^19.01IP^5 ^5
  599   "KRN",19,1 4648,10,1, 0)
  600   14647^^1
  601   "KRN",19,1 4648,10,1, "^")
  602   DG OTH HIS TORY AUDIT  REPORT
  603   "KRN",19,1 4648,10,2, 0)
  604   14649^^2
  605   "KRN",19,1 4648,10,2, "^")
  606   DG OTH EXC EPTION REP ORT
  607   "KRN",19,1 4648,10,3, 0)
  608   14651^^3
  609   "KRN",19,1 4648,10,3, "^")
  610   DG OTH ACT IVE 90-DAY  PERIOD
  611   "KRN",19,1 4648,10,4, 0)
  612   14667^^4
  613   "KRN",19,1 4648,10,4, "^")
  614   DG OTH STA TISTICAL R EPORT
  615   "KRN",19,1 4648,10,5, 0)
  616   14672^^5
  617   "KRN",19,1 4648,10,5, "^")
  618   DG OTH INA CT REPORT
  619   "KRN",19,1 4648,99)
  620   64875,3648 6
  621   "KRN",19,1 4648,"U")
  622   OTHER THAN  HONORABLE  REPORTS
  623   "KRN",19,1 4649,-1)
  624   0^10
  625   "KRN",19,1 4649,0)
  626   DG OTH EXC EPTION REP ORT^Except ion Report s, OTH Pts ^^R^^^^^^^ ^
  627   "KRN",19,1 4649,1,0)
  628   ^19.06^3^3 ^3180815^^
  629   "KRN",19,1 4649,1,1,0 )
  630   These are  the other  than honor able patie nts that a re not cur rently
  631   "KRN",19,1 4649,1,2,0 )
  632   eligible f or care at  this time . It has s everal rep ort option s to assis t in
  633   "KRN",19,1 4649,1,3,0 )
  634   managing t he program .
  635   "KRN",19,1 4649,25)
  636   REPORT^DGO THRP1
  637   "KRN",19,1 4649,"U")
  638   EXCEPTION  REPORTS, O TH PTS
  639   "KRN",19,1 4651,-1)
  640   0^9
  641   "KRN",19,1 4651,0)
  642   DG OTH ACT IVE 90-DAY  PERIOD^Ac tive 90-Da y Period O TH Patient  Report^^R ^^^^^^^^
  643   "KRN",19,1 4651,1,0)
  644   ^^12^12^31 80518^
  645   "KRN",19,1 4651,1,1,0 )
  646   This optio n generate s a report  that prin ts a listi ng of all  Other Than  
  647   "KRN",19,1 4651,1,2,0 )
  648   Honorable  patients w ith ACTIVE  90-Day pe riod of ca re. The us er is prom pted
  649   "KRN",19,1 4651,1,3,0 )
  650   to enter t he date ra nge for in clusion on  the repor t.  The re port can b e
  651   "KRN",19,1 4651,1,4,0 )
  652   sorted by  the follow ing:
  653   "KRN",19,1 4651,1,5,0 )
  654    
  655   "KRN",19,1 4651,1,6,0 )
  656    1. Sort b y Patient  Name
  657   "KRN",19,1 4651,1,7,0 )
  658    2. Sort b y Period
  659   "KRN",19,1 4651,1,8,0 )
  660    3. Sort b y Days Rem aining
  661   "KRN",19,1 4651,1,9,0 )
  662    
  663   "KRN",19,1 4651,1,10, 0)
  664   The listin g shows Pa tient Name , Last Fou r of their  SSN, Peri od, Start 
  665   "KRN",19,1 4651,1,11, 0)
  666   Date, End  Date, Days  Left, and  Authorize d By. 
  667   "KRN",19,1 4651,1,12, 0)
  668   Report pri nts in 80  column for mat. 
  669   "KRN",19,1 4651,25)
  670   REPORT1^DG OTHRPT
  671   "KRN",19,1 4651,"U")
  672   ACTIVE 90- DAY PERIOD  OTH PATIE
  673   "KRN",19,1 4667,-1)
  674   0^12
  675   "KRN",19,1 4667,0)
  676   DG OTH STA TISTICAL R EPORT^OTH  Patient St atistics R eport^^R^^ ^^^^^^
  677   "KRN",19,1 4667,1,0)
  678   ^^2^2^3180 612^
  679   "KRN",19,1 4667,1,1,0 )
  680   This optio n generate s a statis tical repo rt that wi ll display  a listing  of 
  681   "KRN",19,1 4667,1,2,0 )
  682   Other Than  Honorable  patients  treated un der OTH au thority.
  683   "KRN",19,1 4667,25)
  684   ENSTAT^DGO THRPT
  685   "KRN",19,1 4667,"U")
  686   OTH PATIEN T STATISTI CS REPORT
  687   "KRN",19,1 4668,-1)
  688   0^13
  689   "KRN",19,1 4668,0)
  690   DG OTH STO P/REACTIVA TE CLOCK^I nactivate  or Reactiv ate OTH Pt  Countdown  Clock^^R^ ^DG OTH ED IT^^^^^^
  691   "KRN",19,1 4668,1,0)
  692   ^19.06^2^2 ^3190305^^
  693   "KRN",19,1 4668,1,1,0 )
  694   This optio n allow us er to manu ally inact ivate/re-a ctivate Ot her Than 
  695   "KRN",19,1 4668,1,2,0 )
  696   Honorable  patient co untdown cl ock.
  697   "KRN",19,1 4668,25)
  698   EN^DGOTHRI
  699   "KRN",19,1 4668,"U")
  700   INACTIVATE  OR REACTI VATE OTH P
  701   "KRN",19,1 4671,-1)
  702   0^14
  703   "KRN",19,1 4671,0)
  704   DG OTH PAT IENT INQUI RY^Patient  Inquiry -  Other Tha n Honorabl e^^R^^^^^^ ^^
  705   "KRN",19,1 4671,1,0)
  706   ^^1^1^3180 814^
  707   "KRN",19,1 4671,1,1,0 )
  708   Allows use r to do an  inquiry o n a single  Other Tha n Honorabl e patient.
  709   "KRN",19,1 4671,25)
  710   EN^DGOTHIN Q
  711   "KRN",19,1 4671,"U")
  712   PATIENT IN QUIRY - OT HER THAN H
  713   "KRN",19,1 4672,-1)
  714   0^15
  715   "KRN",19,1 4672,0)
  716   DG OTH INA CT REPORT^ Inactivate d/Reactiva ted Report , OTH Pts^ ^R^^^^^^^^
  717   "KRN",19,1 4672,1,0)
  718   ^^2^2^3190 305^
  719   "KRN",19,1 4672,1,1,0 )
  720   Report to  show patie nt that we re inactiv ated and r eactivated  for Other
  721   "KRN",19,1 4672,1,2,0 )
  722   than Honor able patie nts.
  723   "KRN",19,1 4672,25)
  724   INACRPT^DG OTHRP1
  725   "KRN",19,1 4672,"U")
  726   INACTIVATE D/REACTIVA TED REPORT
  727   "KRN",19.1 ,737,-1)
  728   0^1
  729   "KRN",19.1 ,737,0)
  730   DG OTH EDI T^OTH 90-D AY EDIT
  731   "KRN",19.1 ,737,1,0)
  732   ^19.11^2^2 ^3180326^
  733   "KRN",19.1 ,737,1,1,0 )
  734   Allow user  to edit t he start d ate and au thorized b y for the  1st or 2nd  
  735   "KRN",19.1 ,737,1,2,0 )
  736   90-Day per iod of car e for the  Other Than  Honorable  patients.
  737   "MBREQ")
  738   0
  739   "ORD",3,19 .1)
  740   19.1;3;;;K EY^XPDTA1; KEYF1^XPDI A1;KEYE1^X PDIA1;KEYF 2^XPDIA1;; KEYDEL^XPD IA1
  741   "ORD",3,19 .1,0)
  742   SECURITY K EY
  743   "ORD",5,.4 )
  744   .4;5;;;EDE OUT^DIFROM SO(.4,DA," ",XPDA);FP RE^DIFROMS I(.4,"",XP DA);EPRE^D IFROMSI(.4 ,DA,$E("N" ,$G(XPDNEW )),XPDA,"" ,OLDA);;EP OST^DIFROM SI(.4,DA," ",XPDA);DE L^DIFROMSK (.4,"",%)
  745   "ORD",5,.4 ,0)
  746   PRINT TEMP LATE
  747   "ORD",7,.4 02)
  748   .402;7;;;E DEOUT^DIFR OMSO(.402, DA,"",XPDA );FPRE^DIF ROMSI(.402 ,"",XPDA); EPRE^DIFRO MSI(.402,D A,$E("N",$ G(XPDNEW)) ,XPDA,"",O LDA);;EPOS T^DIFROMSI (.402,DA," ",XPDA);DE L^DIFROMSK (.402,"",% )
  749   "ORD",7,.4 02,0)
  750   INPUT TEMP LATE
  751   "ORD",18,1 9)
  752   19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
  753   "ORD",18,1 9,0)
  754   OPTION
  755   "PKG",114, -1)
  756   1^1
  757   "PKG",114, 0)
  758   REGISTRATI ON^DG^PATI ENT REGIST RATION, AD MISSION, D ISCHARGE,  EMBOSSER 
  759   "PKG",114, 22,0)
  760   ^9.49I^1^1
  761   "PKG",114, 22,1,0)
  762   5.3^293081 3^2930821
  763   "PKG",114, 22,1,"PAH" ,1,0)
  764   952^319032 0^52082465 2
  765   "PKG",114, 22,1,"PAH" ,1,1,0)
  766   ^^4^4^3190 320
  767   "PKG",114, 22,1,"PAH" ,1,1,1,0)
  768   This patch  implement s the "EXP ANDED MH C ARE NON VE TERAN" as  a new
  769   "PKG",114, 22,1,"PAH" ,1,1,2,0)
  770   eligibilit y code for  patient r egistratio n. It is u sed to ide ntify and
  771   "PKG",114, 22,1,"PAH" ,1,1,3,0)
  772   track "oth er than ho norably di scharged"  service me mbers for  emergency
  773   "PKG",114, 22,1,"PAH" ,1,1,4,0)
  774   mental hea lth servic es in the  VA.
  775   "QUES","XP F1",0)
  776   Y
  777   "QUES","XP F1","??")
  778   ^D REP^XPD H
  779   "QUES","XP F1","A")
  780   Shall I wr ite over y our |FLAG|  File
  781   "QUES","XP F1","B")
  782   YES
  783   "QUES","XP F1","M")
  784   D XPF1^XPD IQ
  785   "QUES","XP F2",0)
  786   Y
  787   "QUES","XP F2","??")
  788   ^D DTA^XPD H
  789   "QUES","XP F2","A")
  790   Want my da ta |FLAG|  yours
  791   "QUES","XP F2","B")
  792   YES
  793   "QUES","XP F2","M")
  794   D XPF2^XPD IQ
  795   "QUES","XP I1",0)
  796   YO
  797   "QUES","XP I1","??")
  798   ^D INHIBIT ^XPDH
  799   "QUES","XP I1","A")
  800   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  801   "QUES","XP I1","B")
  802   NO
  803   "QUES","XP I1","M")
  804   D XPI1^XPD IQ
  805   "QUES","XP M1",0)
  806   PO^VA(200, :EM
  807   "QUES","XP M1","??")
  808   ^D MG^XPDH
  809   "QUES","XP M1","A")
  810   Enter the  Coordinato r for Mail  Group '|F LAG|'
  811   "QUES","XP M1","B")
  812  
  813   "QUES","XP M1","M")
  814   D XPM1^XPD IQ
  815   "QUES","XP O1",0)
  816   Y
  817   "QUES","XP O1","??")
  818   ^D MENU^XP DH
  819   "QUES","XP O1","A")
  820   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  821   "QUES","XP O1","B")
  822   NO
  823   "QUES","XP O1","M")
  824   D XPO1^XPD IQ
  825   "QUES","XP Z1",0)
  826   Y
  827   "QUES","XP Z1","??")
  828   ^D OPT^XPD H
  829   "QUES","XP Z1","A")
  830   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  831   "QUES","XP Z1","B")
  832   NO
  833   "QUES","XP Z1","M")
  834   D XPZ1^XPD IQ
  835   "QUES","XP Z2",0)
  836   Y
  837   "QUES","XP Z2","??")
  838   ^D RTN^XPD H
  839   "QUES","XP Z2","A")
  840   Want to MO VE routine s to other  CPUs
  841   "QUES","XP Z2","B")
  842   NO
  843   "QUES","XP Z2","M")
  844   D XPZ2^XPD IQ
  845   "RTN")
  846   16
  847   "RTN","DGL OCK1")
  848   0^6^B21160 237
  849   "RTN","DGL OCK1",1,0)
  850   DGLOCK1 ;A LB/MRL - P ATIENT FIL E DATA EDI T CHECK ;2 8 JUL 86
  851   "RTN","DGL OCK1",2,0)
  852    ;;5.3;Reg istration; **121,314, 952**;Aug  13, 1993;B uild 68
  853   "RTN","DGL OCK1",3,0)
  854   AOD ;AO De lete
  855   "RTN","DGL OCK1",4,0)
  856    I $D(^DPT (DFN,.321) ),$P(^(.32 1),U,2)="Y " W !?4,*7 ,"Can't de lete as lo ng as Agen t Orange e xposure is  indicated ." K X
  857   "RTN","DGL OCK1",5,0)
  858    Q
  859   "RTN","DGL OCK1",6,0)
  860   COMD ;Comb at Delete
  861   "RTN","DGL OCK1",7,0)
  862    I $D(^DPT (DFN,.52)) ,$P(^(.52) ,U,11)="Y"  W !?4,*7, "Can't del ete as lon g as Comba t Service  is indicat ed." K X
  863   "RTN","DGL OCK1",8,0)
  864    Q
  865   "RTN","DGL OCK1",9,0)
  866   INED ;Inel igible Del ete
  867   "RTN","DGL OCK1",10,0 )
  868    I $D(^DPT (DFN,.15)) ,$P(^(.15) ,U,2)]"" W  !?4,*7,"C an't delet e this fie ld as long  as 'INELI GIBLE DATE ' is on fi le." K X
  869   "RTN","DGL OCK1",11,0 )
  870    Q
  871   "RTN","DGL OCK1",12,0 )
  872   IRD ;ION R ad Delete
  873   "RTN","DGL OCK1",13,0 )
  874    I $D(^DPT (DFN,.321) ),$P(^(.32 1),U,3)="Y " W !?4,*7 ,"Can't de lete as lo ng as Ioni zing Radia tion expos ure is ind icated." K  X
  875   "RTN","DGL OCK1",14,0 )
  876    Q
  877   "RTN","DGL OCK1",15,0 )
  878   POWD ;POW  Delete
  879   "RTN","DGL OCK1",16,0 )
  880    I $D(^DPT (DFN,.52)) ,$P(^(.52) ,U,5)="Y"  W !?4,*7," Still iden tified as  former POW ...Change  status to  delete." K  X
  881   "RTN","DGL OCK1",17,0 )
  882    Q
  883   "RTN","DGL OCK1",18,0 )
  884   TADD ;Temp  Add Delet e
  885   "RTN","DGL OCK1",19,0 )
  886    I $D(^DPT (DFN,.121) ),$P(^(.12 1),U,9)="Y " W !?4,*7 ,"Answer N O to the ' WANT TO EN TER TEMPOR ARY ADDRES S' prompt,  then dele te." K X
  887   "RTN","DGL OCK1",20,0 )
  888    Q
  889   "RTN","DGL OCK1",21,0 )
  890   VND ;Viet  Svc Delete
  891   "RTN","DGL OCK1",22,0 )
  892    I $D(^DPT (DFN,.321) ),$P(^(.32 1),U,1)="Y " W !?4,*7 ,"Can't de lete as lo ng as Viet nam Servic e is still  indicated ." K X
  893   "RTN","DGL OCK1",23,0 )
  894    Q
  895   "RTN","DGL OCK1",24,0 )
  896   SVDEL ;Pan ama, Grena da, Lebano n, Persian  Gulf Svc  Delete
  897   "RTN","DGL OCK1",25,0 )
  898    ;DGX = pi ece positi on of corr esponding  service in dicated? f ield
  899   "RTN","DGL OCK1",26,0 )
  900    I $D(^DPT (DFN,.322) ),$P(^(.32 2),U,DGX)= "Y" W !?4, *7,"Can't  delete as  long as ", $S(DGX=1:" Lebanon",D GX=4:"Gren ada",DGX=7 :"Panama", 1:"Persian  Gulf"),"  is still i ndicated."  K X
  901   "RTN","DGL OCK1",27,0 )
  902    K DGX
  903   "RTN","DGL OCK1",28,0 )
  904    Q
  905   "RTN","DGL OCK1",29,0 )
  906   EC S DGEC= $S('$D(^DP T(DFN,.36) ):"",$D(^D IC(8,+$P(^ DPT(DFN,.3 6),U,1),0) ):$P(^(0), U,9),1:"")  I DGEC=5  W !?4,*7," Eligibilit y Code is  'NSC'...Ca n't be YES ." K X,DGE C Q
  907   "RTN","DGL OCK1",30,0 )
  908    K DGEC Q
  909   "RTN","DGL OCK1",31,0 )
  910   POS ;Scree n
  911   "RTN","DGL OCK1",32,0 )
  912    K DGEC D  SV1^DGLOCK  I $D(X) S  DIC("S")= "I '$P(^(0 ),""^"",8) ,$D(^DPT(D A,.36)),$D (^DIC(21,+ Y,""E"",+$ P(^(.36),U ,1)))" D ^ DIC K DIC  S DIC=DIE, X=+Y K:Y<0  X D:'$D(X ) POSH I $ D(X),$D(^D IC(21,X,0) ),$P(^(0), U,7)]"" D  POS1 Q
  913   "RTN","DGL OCK1",33,0 )
  914    Q
  915   "RTN","DGL OCK1",34,0 )
  916   POS1 S XX= $P(^DIC(21 ,X,0),U,7)  I $P(^DPT (DA,0),U,3 )]"" I $P( ^(0),U,3)' >XX!($D(^X USEC("DG E LIGIBILITY ",DUZ))) K  XX Q
  917   "RTN","DGL OCK1",35,0 )
  918    W !?5,*7, "Applicant  is too yo ung to hav e served i n that per iod of ser vice.",!?5 ,"See your  superviso r if you r equire ass istance."  K X,XX Q
  919   "RTN","DGL OCK1",36,0 )
  920   POSH S DGE C=$S('$D(^ DPT(DFN,.3 6)):"",$D( ^DIC(8,+$P (^(.36),U, 1),0)):$P( ^(0),U,1), 1:"") W !? 5,"Current  Eligibili ty Code" W :DGEC]"" " : ",DGEC I  DGEC']""  W " is not  defined.   Must be d efined in  order",!?5 ,"to enter  a POS."
  921   "RTN","DGL OCK1",37,0 )
  922    K DGEC Q
  923   "RTN","DGL OCK1",38,0 )
  924   SC S DGSCO N=$S('$D(^ DPT(DFN,.3 )):0,$P(^( .3),U,1)=" Y":1,1:0)  I 'DGSCON  W !?4,*7," Not possib le, applic ant is not  service-c onnected."  K X,DGSCO N Q
  925   "RTN","DGL OCK1",39,0 )
  926    K DGSCON  Q
  927   "RTN","DGL OCK1",40,0 )
  928    ;
  929   "RTN","DGL OCK1",41,0 )
  930   ECD ;prima ry eligibi lity code  input tran sform
  931   "RTN","DGL OCK1",42,0 )
  932    ;
  933   "RTN","DGL OCK1",43,0 )
  934    N DGNODE, DGPC,DGSER ,DGVT,DGXX
  935   "RTN","DGL OCK1",44,0 )
  936    S DGVT=$G (^DPT(DFN, "VET")),DG SER=$S('$D (^DPT(DFN, .3)):0,$P( ^(.3),U,1) ="Y":1,1:0 )
  937   "RTN","DGL OCK1",45,0 )
  938    I DGVT']" " K X W !? 4,*7,"'VET ERAN (Y/N) ' prompt m ust be ans wered to s elect an E ligibility  Code'" Q
  939   "RTN","DGL OCK1",46,0 )
  940    ;screen o ut all ent ries with  the wrong  "veteran"  type, and  inactive a nd those t hat can be  selected  only as ad ditional
  941   "RTN","DGL OCK1",47,0 )
  942    S DIC("S" )="I $P(^D IC(8,+Y,0) ,U,5)=DGVT ,'$P(^(0), U,7)" I DG VT="N" G E CDS
  943   "RTN","DGL OCK1",48,0 )
  944    I DGSER S  DGPC=$S(+ $P(^DPT(DF N,.3),U,2) >49:1,1:0) ,DGXX=$S(D GPC:1,1:3) ,DIC("S")= DIC("S")_" ,($P(^(0), U,9)="_DGX X_")" G EC DS ;sc onl y
  945   "RTN","DGL OCK1",49,0 )
  946    I $P($G(^ DPT(DFN,.5 2)),"^",5) ="Y" S DIC ("S")=DIC( "S")_",($P (^(0),U,9) =18)" G EC DS ;pow on ly
  947   "RTN","DGL OCK1",50,0 )
  948    S DGXX="^ 1^3^18^" ;  no sc<50,  sc 50-100 , pow
  949   "RTN","DGL OCK1",51,0 )
  950    I $P($G(^ DPT(DFN,.5 3)),U)="Y"  S DIC("S" )=DIC("S") _",($P(^(0 ),U,9)=22) " G ECDS ; checks for  PH Indica tor
  951   "RTN","DGL OCK1",52,0 )
  952    S DGXX=DG XX_"22^" ; adds PH to  DGXX stri ng
  953   "RTN","DGL OCK1",53,0 )
  954    S DGNODE= $G(^DPT(DF N,.362))
  955   "RTN","DGL OCK1",54,0 )
  956    I $P(DGNO DE,"^",12) '="Y" S DG XX=DGXX_"2 ^"
  957   "RTN","DGL OCK1",55,0 )
  958    I $P(DGNO DE,"^",14) '="Y" S DG XX=DGXX_"4 ^"
  959   "RTN","DGL OCK1",56,0 )
  960    I $P(DGNO DE,"^",13) '="Y" S DG XX=DGXX_"1 5^"
  961   "RTN","DGL OCK1",57,0 )
  962    F I=12:1: 14 I $P(DG NODE,"^",I )="Y" S DG XX=DGXX_"5 ^"_$S(I'=1 4:"4^",1:" ")
  963   "RTN","DGL OCK1",58,0 )
  964    I $P($G(^ DPT(DFN,0) ),"^",3)>2 200101 S D GXX=DGXX_" 16^17^" ;  WWI or mex ican borde r only
  965   "RTN","DGL OCK1",59,0 )
  966    S DIC("S" )=DIC("S") _",("""_DG XX_"""'[(U _$P(^(0),U ,9)_U))"
  967   "RTN","DGL OCK1",60,0 )
  968   ECDS D ^DI C K DIC S  DIC=DIE,X= +Y K:Y<0 X
  969   "RTN","DGL OCK1",61,0 )
  970    ;
  971   "RTN","DGL OCK1",62,0 )
  972    ;catastro phic disab ility can  not be pri mary
  973   "RTN","DGL OCK1",63,0 )
  974    I $G(X),$ $NATNAME^D GENELA(X)= "CATASTROP HICALLY DI SABLED" K  X Q
  975   "RTN","DGL OCK1",64,0 )
  976    ;
  977   "RTN","DGL OCK1",65,0 )
  978    Q
  979   "RTN","DGO THD")
  980   0^2^B71214 411
  981   "RTN","DGO THD",1,0)
  982   DGOTHD ;SL C/SS,RM -  OTHD (OTHE R THAN HON ORABLE DIS CHARGE) AP Is ;Feb 14 , 2019@09: 57
  983   "RTN","DGO THD",2,0)
  984    ;;5.3;Reg istration; **977,952* *;Aug 13,  1993;Build  68
  985   "RTN","DGO THD",3,0)
  986    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  987   "RTN","DGO THD",4,0)
  988    ;
  989   "RTN","DGO THD",5,0)
  990    ;     Las t Edited:  SHRPE/RM -  Feb 14, 2 019@09:57
  991   "RTN","DGO THD",6,0)
  992    ;
  993   "RTN","DGO THD",7,0)
  994    ;ICR    F or
  995   "RTN","DGO THD",8,0)
  996    ;10043  E LIG^VADPT
  997   "RTN","DGO THD",9,0)
  998    Q
  999   "RTN","DGO THD",10,0)
  1000    ;
  1001   "RTN","DGO THD",11,0)
  1002    ;ask for  the starti ng date fo r the OTH  clock
  1003   "RTN","DGO THD",12,0)
  1004    ;called f rom [DG LO AD EDIT SC REEN 7]
  1005   "RTN","DGO THD",13,0)
  1006   STRDATE(DG DFN) ;
  1007   "RTN","DGO THD",14,0)
  1008    I '$G(DGD FN) Q
  1009   "RTN","DGO THD",15,0)
  1010    N DGSTRDT ,Y
  1011   "RTN","DGO THD",16,0)
  1012    I '$$ISOT HD(DGDFN)  Q
  1013   "RTN","DGO THD",17,0)
  1014    I $$HASCL OCK^DGOTHD 2(DGDFN) Q
  1015   "RTN","DGO THD",18,0)
  1016    I $$GET1^ DIQ(2,DGDF N,.5501,"I ")'="OTH-9 0" Q
  1017   "RTN","DGO THD",19,0)
  1018    D STRDATE 1(DGDFN) ; B2S3
  1019   "RTN","DGO THD",20,0)
  1020    D FRSTCLC K^DGOTHD1( DGDFN,DGST RDT)
  1021   "RTN","DGO THD",21,0)
  1022    Q
  1023   "RTN","DGO THD",22,0)
  1024    ;
  1025   "RTN","DGO THD",23,0)
  1026   STRDATE1(D GDFN) ;
  1027   "RTN","DGO THD",24,0)
  1028    N DGLOOP
  1029   "RTN","DGO THD",25,0)
  1030    S DGLOOP= 0
  1031   "RTN","DGO THD",26,0)
  1032    F  D  Q:D GLOOP=1
  1033   "RTN","DGO THD",27,0)
  1034    . S DGSTR DT=$$ASKDT ^DGOTHD2(" Enter star t date for  1ST 90-Da y OTH cloc k: ","T"," DA^::EX",1 )
  1035   "RTN","DGO THD",28,0)
  1036    . I DGSTR DT'>0 S DG LOOP=1 Q
  1037   "RTN","DGO THD",29,0)
  1038    . I $$FMD IFF^XLFDT( DT,DGSTRDT )>90 W !!, "  The dat e entered  cannot be  more than  90 days in  the past. ",! Q
  1039   "RTN","DGO THD",30,0)
  1040    . I DGSTR DT>DT W !! ,"  A futu re date ca nnot be en tered.",!  Q
  1041   "RTN","DGO THD",31,0)
  1042    . S DGLOO P=1
  1043   "RTN","DGO THD",32,0)
  1044    Q
  1045   "RTN","DGO THD",33,0)
  1046    ;
  1047   "RTN","DGO THD",34,0)
  1048   ASKREQDT(M AXDT) ; pr ompt for d ate reques t submitte d
  1049   "RTN","DGO THD",35,0)
  1050    ;
  1051   "RTN","DGO THD",36,0)
  1052    ; MAXDT =  latest al lowed date  (required )
  1053   "RTN","DGO THD",37,0)
  1054    ;
  1055   "RTN","DGO THD",38,0)
  1056    ; returns  date in i nternal FM  format or  0 on user  exit
  1057   "RTN","DGO THD",39,0)
  1058    ;
  1059   "RTN","DGO THD",40,0)
  1060    N DIR,DIR UT,DIROUT, DTOUT,DUOU T,X,Y
  1061   "RTN","DGO THD",41,0)
  1062    S DIR(0)= "D^:"_MAXD T_":ESTX"
  1063   "RTN","DGO THD",42,0)
  1064    S DIR("A" )="Date re quest subm itted"
  1065   "RTN","DGO THD",43,0)
  1066    S DIR("?" ,1)="Enter  the date  authorizat ion reques t was subm itted."
  1067   "RTN","DGO THD",44,0)
  1068    S DIR("?" ,2)="This  date must  be in the  past. Time  entry is  allowed."
  1069   "RTN","DGO THD",45,0)
  1070    S DIR("?" )="Latest  allowed da te/time is  "_$$FMTE^ XLFDT(MAXD T)
  1071   "RTN","DGO THD",46,0)
  1072    D ^DIR
  1073   "RTN","DGO THD",47,0)
  1074    I $D(DTOU T)!$D(DUOU T) Q 0
  1075   "RTN","DGO THD",48,0)
  1076    Q +Y
  1077   "RTN","DGO THD",49,0)
  1078    ;
  1079   "RTN","DGO THD",50,0)
  1080   ASKAUAP()  ; prompt f or authori zation app roved
  1081   "RTN","DGO THD",51,0)
  1082    ;
  1083   "RTN","DGO THD",52,0)
  1084    ; returns  "Y" for a pproved, " N" for not  approved,  "P" for p ending, or  "" on use r exit
  1085   "RTN","DGO THD",53,0)
  1086    ;
  1087   "RTN","DGO THD",54,0)
  1088    N DIR,DIR UT,DIROUT, DTOUT,DUOU T,X,Y
  1089   "RTN","DGO THD",55,0)
  1090    S DIR(0)= "SA^Y:Yes; N:No;P:Pen ding"
  1091   "RTN","DGO THD",56,0)
  1092    S DIR("A" )="Authori zation app roved (Y/N /P): "
  1093   "RTN","DGO THD",57,0)
  1094    D ^DIR
  1095   "RTN","DGO THD",58,0)
  1096    I $D(DTOU T)!$D(DUOU T) Q ""
  1097   "RTN","DGO THD",59,0)
  1098    Q Y
  1099   "RTN","DGO THD",60,0)
  1100    ;
  1101   "RTN","DGO THD",61,0)
  1102   ASKAUBY()  ; prompt f or authori zed by
  1103   "RTN","DGO THD",62,0)
  1104    ;
  1105   "RTN","DGO THD",63,0)
  1106    ; returns  name of t he user se lected or  "" on user  exit
  1107   "RTN","DGO THD",64,0)
  1108    ;
  1109   "RTN","DGO THD",65,0)
  1110    N DIR,DIR UT,DIROUT, DTOUT,DUOU T,X,Y
  1111   "RTN","DGO THD",66,0)
  1112    S DIR(0)= "FA^1:60"
  1113   "RTN","DGO THD",67,0)
  1114    S DIR("A" )="Authori zed by: "
  1115   "RTN","DGO THD",68,0)
  1116    S DIR("?" )="Free te xt name, 1  to 60 cha racters in  length."
  1117   "RTN","DGO THD",69,0)
  1118    D ^DIR
  1119   "RTN","DGO THD",70,0)
  1120    I $D(DTOU T)!$D(DUOU T) Q ""
  1121   "RTN","DGO THD",71,0)
  1122    Q Y
  1123   "RTN","DGO THD",72,0)
  1124    ;
  1125   "RTN","DGO THD",73,0)
  1126   ASKAURDT(M AXDT) ; pr ompt for a uthorizati on receive d date
  1127   "RTN","DGO THD",74,0)
  1128    ;
  1129   "RTN","DGO THD",75,0)
  1130    ; MAXDT =  latest al lowed date  (required )
  1131   "RTN","DGO THD",76,0)
  1132    ;
  1133   "RTN","DGO THD",77,0)
  1134    ; returns  date in i nternal FM  format or  0 on user  exit
  1135   "RTN","DGO THD",78,0)
  1136    ;
  1137   "RTN","DGO THD",79,0)
  1138    N DIR,DIR UT,DIROUT, DTOUT,DUOU T,X,Y
  1139   "RTN","DGO THD",80,0)
  1140    S DIR(0)= "D^:"_MAXD T_":ESTX"
  1141   "RTN","DGO THD",81,0)
  1142    S DIR("A" )="Authori zation rec eived date "
  1143   "RTN","DGO THD",82,0)
  1144    S DIR("?" ,1)="Enter  the date  authorizat ion was re ceived."
  1145   "RTN","DGO THD",83,0)
  1146    S DIR("?" ,2)="This  date must  be in the  past. Time  entry is  allowed."
  1147   "RTN","DGO THD",84,0)
  1148    S DIR("?" )="Latest  allowed da te/time is  "_$$FMTE^ XLFDT(MAXD T)
  1149   "RTN","DGO THD",85,0)
  1150    D ^DIR
  1151   "RTN","DGO THD",86,0)
  1152    I $D(DTOU T)!$D(DUOU T) Q 0
  1153   "RTN","DGO THD",87,0)
  1154    Q +Y
  1155   "RTN","DGO THD",88,0)
  1156    ;
  1157   "RTN","DGO THD",89,0)
  1158   ASKSTDT(MI NDT,MAXDT)  ; prompt  for period  start dat e
  1159   "RTN","DGO THD",90,0)
  1160    ;
  1161   "RTN","DGO THD",91,0)
  1162    ; MINDT =  earliest  allowed da te (requir ed)
  1163   "RTN","DGO THD",92,0)
  1164    ; MAXDT =  latest al lowed date  (required )
  1165   "RTN","DGO THD",93,0)
  1166    ;
  1167   "RTN","DGO THD",94,0)
  1168    ; returns  date in i nternal FM  format or  0 on user  exit
  1169   "RTN","DGO THD",95,0)
  1170    ;
  1171   "RTN","DGO THD",96,0)
  1172    N DIR,DIR UT,DIROUT, DTOUT,DUOU T,X,Y
  1173   "RTN","DGO THD",97,0)
  1174    N MAXDTE, MINDTE
  1175   "RTN","DGO THD",98,0)
  1176    ; get min  and max d ates in ex ternal for mat
  1177   "RTN","DGO THD",99,0)
  1178    S MINDTE= $$FMTE^XLF DT(MINDT), MAXDTE=$$F MTE^XLFDT( MAXDT)
  1179   "RTN","DGO THD",100,0 )
  1180    S DIR(0)= "D^"_MINDT _":"_MAXDT _":ESTX"
  1181   "RTN","DGO THD",101,0 )
  1182    S DIR("A" )="Period  start date  ("_MINDTE _" - "_MAX DTE_")"
  1183   "RTN","DGO THD",102,0 )
  1184    S DIR("B" )=MINDTE
  1185   "RTN","DGO THD",103,0 )
  1186    S DIR("?" ,1)="Enter  the start  date of t his 90 day  period. T ime entry  is allowed ."
  1187   "RTN","DGO THD",104,0 )
  1188    S DIR("?" ,2)="Earli est allowe d date/tim e is "_MIN DTE
  1189   "RTN","DGO THD",105,0 )
  1190    S DIR("?" )="Latest  allowed da te/time is  "_MAXDTE
  1191   "RTN","DGO THD",106,0 )
  1192    D ^DIR
  1193   "RTN","DGO THD",107,0 )
  1194    I $D(DTOU T)!$D(DUOU T) Q 0
  1195   "RTN","DGO THD",108,0 )
  1196    Q +Y
  1197   "RTN","DGO THD",109,0 )
  1198    ;
  1199   "RTN","DGO THD",110,0 )
  1200   ASKAUCMT()  ; prompt  for author ization co mment
  1201   "RTN","DGO THD",111,0 )
  1202    ;
  1203   "RTN","DGO THD",112,0 )
  1204    ; returns  entered c omment or  "" on user  exit
  1205   "RTN","DGO THD",113,0 )
  1206    ;
  1207   "RTN","DGO THD",114,0 )
  1208    N DIR,DIR UT,DIROUT, DTOUT,DUOU T,X,Y
  1209   "RTN","DGO THD",115,0 )
  1210    S DIR(0)= "FA^1:60"
  1211   "RTN","DGO THD",116,0 )
  1212    S DIR("A" )="Authori zation com ment: "
  1213   "RTN","DGO THD",117,0 )
  1214    S DIR("?" )="Free te xt comment , 1 to 60  characters  in length ."
  1215   "RTN","DGO THD",118,0 )
  1216    D ^DIR
  1217   "RTN","DGO THD",119,0 )
  1218    I $D(DTOU T)!$D(DUOU T) Q ""
  1219   "RTN","DGO THD",120,0 )
  1220    Q Y
  1221   "RTN","DGO THD",121,0 )
  1222    ;
  1223   "RTN","DGO THD",122,0 )
  1224   DISPERR(DG ERR) ; dis play error  message
  1225   "RTN","DGO THD",123,0 )
  1226    ;
  1227   "RTN","DGO THD",124,0 )
  1228    ; DGERR -  message t o display
  1229   "RTN","DGO THD",125,0 )
  1230    ;
  1231   "RTN","DGO THD",126,0 )
  1232    W !!,"Err or while f iling OTH  data:",!,D GERR
  1233   "RTN","DGO THD",127,0 )
  1234    Q
  1235   "RTN","DGO THD",128,0 )
  1236    ;
  1237   "RTN","DGO THD",129,0 )
  1238   AUTH90DS ;  authorize  additiona l 90 days  period
  1239   "RTN","DGO THD",130,0 )
  1240    ; entry p oint for " Start Addi tional 90- Days Perio d" option
  1241   "RTN","DGO THD",131,0 )
  1242    ;
  1243   "RTN","DGO THD",132,0 )
  1244    ; data en tered is s aved in OT HDATA stri ng as foll ows:
  1245   "RTN","DGO THD",133,0 )
  1246    ;  p1 = 3 65 days pe riod # to  be filed
  1247   "RTN","DGO THD",134,0 )
  1248    ;  p2 = 9 0 days per iod # to b e filed
  1249   "RTN","DGO THD",135,0 )
  1250    ;  p3 = d ate reques t submitte d
  1251   "RTN","DGO THD",136,0 )
  1252    ;  p4 = a uthorized  by (name)
  1253   "RTN","DGO THD",137,0 )
  1254    ;  p5 = a uthorizati on receive d date
  1255   "RTN","DGO THD",138,0 )
  1256    ;  p6 = s tart date  of this 90  days peri od
  1257   "RTN","DGO THD",139,0 )
  1258    ;  p7 = a uthorizati on comment
  1259   "RTN","DGO THD",140,0 )
  1260    ;  p8 = e ntered by  (name)
  1261   "RTN","DGO THD",141,0 )
  1262    ;  p9 = f acility (f ile 4 ien)
  1263   "RTN","DGO THD",142,0 )
  1264    ;
  1265   "RTN","DGO THD",143,0 )
  1266    N DAYS,DG DFN,DGFRES ,DGIEN33,D TSTR,EDT,M AXDT,MINDT ,NUM365,NU M90,OTHDAT A,SDT,STOP ,Z
  1267   "RTN","DGO THD",144,0 )
  1268    ;keep ask ing for pa tient sele ction unti l empty in put
  1269   "RTN","DGO THD",145,0 )
  1270    S STOP=0  F  W ! S D GIEN33=$$S ELPAT^DGOT HD2(.Z),DG DFN=+$G(Z( 0)) Q:DGIE N33'>0!(DG DFN'>0)  D
  1271   "RTN","DGO THD",146,0 )
  1272    .W @IOF D  HEADER(DG DFN) ; dis play heade r
  1273   "RTN","DGO THD",147,0 )
  1274    .K OTHDAT A,Z S Z=$$ LASTPRD^DG OTHUT1(DGI EN33),NUM3 65=$P(Z,U) ,NUM90=$P( Z,U,3) ; g et data fo r the last  clock per iod
  1275   "RTN","DGO THD",148,0 )
  1276    .W !!,"36 5 Days Per iod: ",$S( NUM365>0:N UM365,1:"N one")
  1277   "RTN","DGO THD",149,0 )
  1278    .W !,"90   Days Peri od: ",$S(N UM90>0:NUM 90,1:"None ")
  1279   "RTN","DGO THD",150,0 )
  1280    .S DTSTR= $$GET365DT ^DGOTHUT1( DGIEN33,$P (Z,U,2)) ;  get dates  for the l ast 365 da y period
  1281   "RTN","DGO THD",151,0 )
  1282    .; find o ut which 3 65 day per iod we're  going to u se
  1283   "RTN","DGO THD",152,0 )
  1284    .S OTHDAT A=$S($$FMD IFF^XLFDT( DT,$P(DTST R,U,2))>0: NUM365+1,1 :NUM365)
  1285   "RTN","DGO THD",153,0 )
  1286    .; find o ut which 9 0 day peri od we're g oing to us e
  1287   "RTN","DGO THD",154,0 )
  1288    .S $P(OTH DATA,U,2)= $S(OTHDATA =NUM365:NU M90+1,1:1)
  1289   "RTN","DGO THD",155,0 )
  1290    .S DTSTR= $$GET90DT^ DGOTHUT1(D GIEN33,$P( Z,U,2),$P( Z,U,4)) ;  get dates  for the la st 90 day  period
  1291   "RTN","DGO THD",156,0 )
  1292    .S SDT=$P (DTSTR,U), EDT=$P(DTS TR,U,2),DA YS=$P(DTST R,U,3)
  1293   "RTN","DGO THD",157,0 )
  1294    .I SDT>0  W !!,"The  most recen t period s tarted on  ",$$FMTE^X LFDT(SDT), " and end" ,$S(EDT<DT :"ed on "_ $$FMTE^XLF DT(EDT),ED T>DT:"s on  "_$$FMTE^ XLFDT(EDT) ,1:"s toda y")
  1295   "RTN","DGO THD",158,0 )
  1296    .W !!,"Da ys Remaini ng: ",$S(S DT>0:DAYS, 1:"N/A")
  1297   "RTN","DGO THD",159,0 )
  1298    .; displa y confirma tion promp t if curre nt 90 day  period is  greater th an 2 (last  90 day pe riod is gr eater than  1)
  1299   "RTN","DGO THD",160,0 )
  1300    .I NUM90> 1 D  Q:STO P
  1301   "RTN","DGO THD",161,0 )
  1302    ..W !!,"P atient has  received  180 days o r more of  care"
  1303   "RTN","DGO THD",162,0 )
  1304    ..I $$YES NO^DGOTHD2 ("Do you w ish to con tinue (Y/N )",,1)'=1  S STOP=1
  1305   "RTN","DGO THD",163,0 )
  1306    ..Q
  1307   "RTN","DGO THD",164,0 )
  1308    .; put cu rrent user  and facil ity into O THDATA
  1309   "RTN","DGO THD",165,0 )
  1310    .S $P(OTH DATA,U,8)= $$UP^XLFST R($$NAME^X USER(DUZ," F"))
  1311   "RTN","DGO THD",166,0 )
  1312    .S $P(OTH DATA,U,9)= $P($$SITE^ VASITE(),U )
  1313   "RTN","DGO THD",167,0 )
  1314    .; prompt  for Date  request su bmitted
  1315   "RTN","DGO THD",168,0 )
  1316    .S Z=$$AS KREQDT(DT)  I Z'>0 Q
  1317   "RTN","DGO THD",169,0 )
  1318    .S $P(OTH DATA,U,3)= Z
  1319   "RTN","DGO THD",170,0 )
  1320    .; prompt  for Autho rization a pproval
  1321   "RTN","DGO THD",171,0 )
  1322    .S Z=$$AS KAUAP() I  Z="" Q
  1323   "RTN","DGO THD",172,0 )
  1324    .; if pen ding, file  data and  quit
  1325   "RTN","DGO THD",173,0 )
  1326    .I Z="P"  S DGFRES=$ $FILEPRD^D GOTHUT1(DG DFN,OTHDAT A) D:'+DGF RES DISPER R($P(DGFRE S,U,2)) Q
  1327   "RTN","DGO THD",174,0 )
  1328    .; if no,  ask for a uthorizati on comment , file dat a and quit
  1329   "RTN","DGO THD",175,0 )
  1330    .I Z="N"  D  Q
  1331   "RTN","DGO THD",176,0 )
  1332    ..S Z=$$A SKAUCMT()  I Z="" Q
  1333   "RTN","DGO THD",177,0 )
  1334    ..S $P(OT HDATA,U,7) =Z
  1335   "RTN","DGO THD",178,0 )
  1336    ..S DGFRE S=$$FILEPR D^DGOTHUT1 (DGDFN,OTH DATA)
  1337   "RTN","DGO THD",179,0 )
  1338    ..I '+DGF RES D DISP ERR($P(DGF RES,U,2))
  1339   "RTN","DGO THD",180,0 )
  1340    ..Q
  1341   "RTN","DGO THD",181,0 )
  1342    .; prompt  for autho rized by
  1343   "RTN","DGO THD",182,0 )
  1344    .S Z=$$AS KAUBY() I  Z="" Q
  1345   "RTN","DGO THD",183,0 )
  1346    .S $P(OTH DATA,U,4)= Z
  1347   "RTN","DGO THD",184,0 )
  1348    .; prompt  for autho rization r eceived da te
  1349   "RTN","DGO THD",185,0 )
  1350    .S Z=$$AS KAURDT(DT)  I Z'>0 Q
  1351   "RTN","DGO THD",186,0 )
  1352    .S $P(OTH DATA,U,5)= Z
  1353   "RTN","DGO THD",187,0 )
  1354    .; calcul ate date r ange for t he next pr ompt
  1355   "RTN","DGO THD",188,0 )
  1356    .; earlie st date al lowed is t he end dat e of the l ast 90 day s period +  1
  1357   "RTN","DGO THD",189,0 )
  1358    .; latest  date is t he start d ate of the  last 90 d ays period  + 365
  1359   "RTN","DGO THD",190,0 )
  1360    .S MINDT= $S(EDT>0:$ $FMADD^XLF DT($P(EDT, "."),1),1: DT)
  1361   "RTN","DGO THD",191,0 )
  1362    .S MAXDT= $$FMADD^XL FDT($S(SDT >0:$P(SDT, "."),1:DT) ,365)
  1363   "RTN","DGO THD",192,0 )
  1364    .; prompt  for perio d start da te
  1365   "RTN","DGO THD",193,0 )
  1366    .S Z=$$AS KSTDT(MIND T,MAXDT) I  Z'>0 Q
  1367   "RTN","DGO THD",194,0 )
  1368    .S $P(OTH DATA,U,6)= Z
  1369   "RTN","DGO THD",195,0 )
  1370    .; file d ata
  1371   "RTN","DGO THD",196,0 )
  1372    .S DGFRES =$$FILEPRD ^DGOTHUT1( DGDFN,OTHD ATA)
  1373   "RTN","DGO THD",197,0 )
  1374    .I '+DGFR ES D DISPE RR($P(DGFR ES,U,2)) Q
  1375   "RTN","DGO THD",198,0 )
  1376    .W !!,"Th e patient  has been a uthorized  for an add itional 90  Days peri od"
  1377   "RTN","DGO THD",199,0 )
  1378    .W !,"wit h the star ting date  of ",$$FMT E^XLFDT($P (OTHDATA,U ,6))
  1379   "RTN","DGO THD",200,0 )
  1380    .Q
  1381   "RTN","DGO THD",201,0 )
  1382    Q
  1383   "RTN","DGO THD",202,0 )
  1384    ;
  1385   "RTN","DGO THD",203,0 )
  1386    ;calculat e the defa ult 2nd 90 -Day date  range
  1387   "RTN","DGO THD",204,0 )
  1388   GETSTDT(DG DAT,DGRES)  ;
  1389   "RTN","DGO THD",205,0 )
  1390    ;  Input:
  1391   "RTN","DGO THD",206,0 )
  1392    ;    DGAD T - The en d date of  the 1st pe riod + 1 d ay
  1393   "RTN","DGO THD",207,0 )
  1394    ;
  1395   "RTN","DGO THD",208,0 )
  1396    ;  Output :
  1397   "RTN","DGO THD",209,0 )
  1398    ;   Funct ion Value  - Second 9 0-Day star t date in  FM format  on success , 0 on fai lure
  1399   "RTN","DGO THD",210,0 )
  1400    ;
  1401   "RTN","DGO THD",211,0 )
  1402    N DGSTDT, DGDIFF,DGS TRTDT,DGEN DDT  ;func tion value
  1403   "RTN","DGO THD",212,0 )
  1404    S DGSTDT= 0
  1405   "RTN","DGO THD",213,0 )
  1406    I +$G(DGD AT)>0 D
  1407   "RTN","DGO THD",214,0 )
  1408    . S DGDAT =+$$FMTH^X LFDT(DGDAT )
  1409   "RTN","DGO THD",215,0 )
  1410    . S DGSTR TDT=$P(DGR ES,U,3)
  1411   "RTN","DGO THD",216,0 )
  1412    . S DGEND DT=$P(DGRE S,U,4)
  1413   "RTN","DGO THD",217,0 )
  1414    . S DGDIF F=363-($$F MDIFF^XLFD T(DGENDDT, DGSTRTDT,1 ))
  1415   "RTN","DGO THD",218,0 )
  1416    . S DGSTD T=+$$HTFM^ XLFDT(DGDA T+DGDIFF)
  1417   "RTN","DGO THD",219,0 )
  1418    Q DGSTDT
  1419   "RTN","DGO THD",220,0 )
  1420    ;
  1421   "RTN","DGO THD",221,0 )
  1422    ;
  1423   "RTN","DGO THD",222,0 )
  1424    ;Function ality:
  1425   "RTN","DGO THD",223,0 )
  1426    ; Impleme nts ICR# 6 873
  1427   "RTN","DGO THD",224,0 )
  1428    ; This fu nction is  called fro m GET^OROT HCL to sup port
  1429   "RTN","DGO THD",225,0 )
  1430    ; the "OR  OTHD CLOC K GET" RPC
  1431   "RTN","DGO THD",226,0 )
  1432    ;It check s if the p atient is  eligible f or OTHD
  1433   "RTN","DGO THD",227,0 )
  1434    ;and retu rns the OT HD status  on the giv en date
  1435   "RTN","DGO THD",228,0 )
  1436    ;
  1437   "RTN","DGO THD",229,0 )
  1438    ;
  1439   "RTN","DGO THD",230,0 )
  1440    ;Paramete rs:
  1441   "RTN","DGO THD",231,0 )
  1442    ; DGDFN -  the patie nt's IEN i n the file  (#2)
  1443   "RTN","DGO THD",232,0 )
  1444    ; DGDATE  - the date  to calcul ate status
  1445   "RTN","DGO THD",233,0 )
  1446    ;           default  = DT (toda y)
  1447   "RTN","DGO THD",234,0 )
  1448    ;
  1449   "RTN","DGO THD",235,0 )
  1450    ;Return v alues:
  1451   "RTN","DGO THD",236,0 )
  1452    ;
  1453   "RTN","DGO THD",237,0 )
  1454    ;return 0  
  1455   "RTN","DGO THD",238,0 )
  1456    ;  if pat ient is no t eligible  for OTHD  in registr ation
  1457   "RTN","DGO THD",239,0 )
  1458    ;  if pat ient does  not have a n entry in  the OTHD  clock file  (#33)
  1459   "RTN","DGO THD",240,0 )
  1460    ;
  1461   "RTN","DGO THD",241,0 )
  1462    ;
  1463   "RTN","DGO THD",242,0 )
  1464   OTHDCLCK(D GDFN,DGDAT E) ;
  1465   "RTN","DGO THD",243,0 )
  1466    ;check th e version  of CPRS is  V31b 
  1467   "RTN","DGO THD",244,0 )
  1468    ;
  1469   "RTN","DGO THD",245,0 )
  1470    ;If it is  CPRS 31b  then
  1471   "RTN","DGO THD",246,0 )
  1472    Q $$OTHCL 31B^DGOTHC LK(DGDFN,D GDATE)
  1473   "RTN","DGO THD",247,0 )
  1474    ;If it is  CPRS EP < TBD>
  1475   "RTN","DGO THD",248,0 )
  1476    ;Q OTHCLE P^DGOTHCLK (DGDFN,DGD ATE)
  1477   "RTN","DGO THD",249,0 )
  1478    ;
  1479   "RTN","DGO THD",250,0 )
  1480    ;
  1481   "RTN","DGO THD",251,0 )
  1482    ;Function ality:
  1483   "RTN","DGO THD",252,0 )
  1484    ; checks  OTHD eligi bility
  1485   "RTN","DGO THD",253,0 )
  1486    ;
  1487   "RTN","DGO THD",254,0 )
  1488    ;Paramete rs:
  1489   "RTN","DGO THD",255,0 )
  1490    ; DFN - p atient's I EN in the  file (#2)
  1491   "RTN","DGO THD",256,0 )
  1492    ;
  1493   "RTN","DGO THD",257,0 )
  1494    ;Return v alues:
  1495   "RTN","DGO THD",258,0 )
  1496    ; 0 - not  eligible  for OTHD
  1497   "RTN","DGO THD",259,0 )
  1498    ; 1 - eli gible for  OTHD
  1499   "RTN","DGO THD",260,0 )
  1500    ;
  1501   "RTN","DGO THD",261,0 )
  1502   ISOTHD(DFN ) ;
  1503   "RTN","DGO THD",262,0 )
  1504    N VAEL,DG IEN,DGOTHD
  1505   "RTN","DGO THD",263,0 )
  1506    D ELIG^VA DPT
  1507   "RTN","DGO THD",264,0 )
  1508    S DGIEN=0 ,DGOTHD=0
  1509   "RTN","DGO THD",265,0 )
  1510    I +VAEL(1 )>0,$P($G( ^DIC(8,+VA EL(1),0)), "^",9)=23  S DGOTHD=1
  1511   "RTN","DGO THD",266,0 )
  1512    Q DGOTHD
  1513   "RTN","DGO THD",267,0 )
  1514    ;
  1515   "RTN","DGO THD",268,0 )
  1516   HEADER(DFN ) ;
  1517   "RTN","DGO THD",269,0 )
  1518    N DDASH,D GNAME,DGDO B,VADM
  1519   "RTN","DGO THD",270,0 )
  1520    D DEM^VAD PT ;get pa tient demo graphics
  1521   "RTN","DGO THD",271,0 )
  1522    S DGNAME= VADM(1),DG DOB=$P(VAD M(3),U,2)
  1523   "RTN","DGO THD",272,0 )
  1524    W ?24,"ST ART ADDITI ONAL 90-DA Y PERIOD"
  1525   "RTN","DGO THD",273,0 )
  1526    W !,"Pati ent Name:  ",DGNAME,? 60,"DOB: " ,DGDOB
  1527   "RTN","DGO THD",274,0 )
  1528    S $P(DDAS H,"=",81)= "" W !,DDA SH,! ;writ e dash lin es
  1529   "RTN","DGO THD",275,0 )
  1530    Q
  1531   "RTN","DGO THD",276,0 )
  1532    ;
  1533   "RTN","DGO THD",277,0 )
  1534    ;retrieve  the defau lt EXPANDE D MH CARE  TYPE
  1535   "RTN","DGO THD",278,0 )
  1536   GETEXPMH(D FN) ;
  1537   "RTN","DGO THD",279,0 )
  1538    ;  Input:
  1539   "RTN","DGO THD",280,0 )
  1540    ;    DFN  - Patient  IEN
  1541   "RTN","DGO THD",281,0 )
  1542    ;
  1543   "RTN","DGO THD",282,0 )
  1544    ;  Output :
  1545   "RTN","DGO THD",283,0 )
  1546    ;    EXPA NDED MH CA RE TYPE (F ile #2,Fie ld #.5501)
  1547   "RTN","DGO THD",284,0 )
  1548    ;
  1549   "RTN","DGO THD",285,0 )
  1550    N VAEL
  1551   "RTN","DGO THD",286,0 )
  1552    D ELIG^VA DPT
  1553   "RTN","DGO THD",287,0 )
  1554    Q $P($G(V AEL(10)),U ,2)
  1555   "RTN","DGO THD",288,0 )
  1556    ;
  1557   "RTN","DGO THD",289,0 )
  1558    ;this is  called by  RPC "GET E XPANDED MH  CARE TYPE "
  1559   "RTN","DGO THD",290,0 )
  1560   GETEXPR(RE T,DFN) ;
  1561   "RTN","DGO THD",291,0 )
  1562    ;  Input:
  1563   "RTN","DGO THD",292,0 )
  1564    ;    DFN  - Patient  IEN
  1565   "RTN","DGO THD",293,0 )
  1566    ;
  1567   "RTN","DGO THD",294,0 )
  1568    ;  Output :
  1569   "RTN","DGO THD",295,0 )
  1570    ;    RET  - EXPANDED  MH CARE T YPE
  1571   "RTN","DGO THD",296,0 )
  1572    ;
  1573   "RTN","DGO THD",297,0 )
  1574    S RET=$$G ETEXPMH(DF N)
  1575   "RTN","DGO THD",298,0 )
  1576    Q
  1577   "RTN","DGO THD",299,0 )
  1578    ;
  1579   "RTN","DGO THD1")
  1580   0^4^B61648 572
  1581   "RTN","DGO THD1",1,0)
  1582   DGOTHD1 ;S LC/SS,MKN, RM - OTHD  (OTHER THA N HONORABL E DISCHARG E) APIs ;1 2/27/17
  1583   "RTN","DGO THD1",2,0)
  1584    ;;5.3;Reg istration; **977,952* *;Aug 13,  1993;Build  68
  1585   "RTN","DGO THD1",3,0)
  1586    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  1587   "RTN","DGO THD1",4,0)
  1588    ;
  1589   "RTN","DGO THD1",5,0)
  1590    Q
  1591   "RTN","DGO THD1",6,0)
  1592    ;
  1593   "RTN","DGO THD1",7,0)
  1594    ;ICR#   T YPE        DESCRIPTIO N
  1595   "RTN","DGO THD1",8,0)
  1596    ;-----  - ---        ---------- ---------- -
  1597   "RTN","DGO THD1",9,0)
  1598    ;10103  S up         ^XLFDT: $$ FMADD,$$FM TE,$$FMDIF F,$$HTFM
  1599   "RTN","DGO THD1",10,0 )
  1600    ;10061  S up         ^VADPT: EL IG
  1601   "RTN","DGO THD1",11,0 )
  1602    ;10142  S up         ^DDIOL: EN
  1603   "RTN","DGO THD1",12,0 )
  1604    ; 2053  S up         ^DIE  : FI LE
  1605   "RTN","DGO THD1",13,0 )
  1606    ; 2056  S up         ^DIQ  : GE T1
  1607   "RTN","DGO THD1",14,0 )
  1608    ;
  1609   "RTN","DGO THD1",15,0 )
  1610    ;set 90 d ays clock  with autho rization 
  1611   "RTN","DGO THD1",16,0 )
  1612   SETAUTH(DG DFN,DGSTRD T,DG365N,D GCL90N,DGA UDUZ,DGAUD T,DGAUTHRZ DBY) ;
  1613   "RTN","DGO THD1",17,0 )
  1614    N DGIEN33 ,DGIEN365
  1615   "RTN","DGO THD1",18,0 )
  1616    ;does the  patient h ave the cl ock?
  1617   "RTN","DGO THD1",19,0 )
  1618    S DGIEN33 =$$HASCLOC K^DGOTHD2( DGDFN) I D GIEN33'>0  Q -1  ; No  clock rec ord
  1619   "RTN","DGO THD1",20,0 )
  1620    S DGIEN36 5=$$CHCK36 5^DGOTHD2( DGIEN33,DG 365N)
  1621   "RTN","DGO THD1",21,0 )
  1622    I DGIEN36 5<0 Q -1   ; OTH cloc k entry in  the file  #33 doesn' t exist
  1623   "RTN","DGO THD1",22,0 )
  1624    I DGIEN36 5=0 Q -2   ; this 365  clock doe s not exis t
  1625   "RTN","DGO THD1",23,0 )
  1626    ;create 9 0 days clo ck
  1627   "RTN","DGO THD1",24,0 )
  1628    S DGIEN90 =$$CR90CLK ^DGOTHD2(+ DGIEN33,+D GIEN365,DG CL90N,DGST RDT,DGAUDU Z,DGAUDT,D GAUTHRZDBY )
  1629   "RTN","DGO THD1",25,0 )
  1630    ;if error  then retu rn error
  1631   "RTN","DGO THD1",26,0 )
  1632    I DGIEN90 <0 Q DGIEN 90
  1633   "RTN","DGO THD1",27,0 )
  1634    Q 1
  1635   "RTN","DGO THD1",28,0 )
  1636    ;
  1637   "RTN","DGO THD1",29,0 )
  1638    ;
  1639   "RTN","DGO THD1",30,0 )
  1640    ;Set the  very first  clock 
  1641   "RTN","DGO THD1",31,0 )
  1642    ;Paramete rs:
  1643   "RTN","DGO THD1",32,0 )
  1644    ; DGDFN -  patient I EN
  1645   "RTN","DGO THD1",33,0 )
  1646    ; DGSTRTD T - starti ng date
  1647   "RTN","DGO THD1",34,0 )
  1648    ;Return v alues:
  1649   "RTN","DGO THD1",35,0 )
  1650    ; <0 if e rror
  1651   "RTN","DGO THD1",36,0 )
  1652    ; 1 if ev erything w as created  properly
  1653   "RTN","DGO THD1",37,0 )
  1654   FRSTCLCK(D GDFN,DGSTR DT) ;
  1655   "RTN","DGO THD1",38,0 )
  1656    N DGIEN33 ,DGIEN365, DGIEN90
  1657   "RTN","DGO THD1",39,0 )
  1658    ;does the  patient h ave the cl ock?
  1659   "RTN","DGO THD1",40,0 )
  1660    S DGIEN33 =$$HASCLOC K^DGOTHD2( DGDFN) I D GIEN33>0 Q  -2  ; alr eady has c lock
  1661   "RTN","DGO THD1",41,0 )
  1662    ;if not t hen create  it
  1663   "RTN","DGO THD1",42,0 )
  1664    I DGIEN33 =0 S DGIEN 33=$$CROTH CLK^DGOTHD 2(DGDFN)
  1665   "RTN","DGO THD1",43,0 )
  1666    ;if error  then retu rn error
  1667   "RTN","DGO THD1",44,0 )
  1668    I DGIEN33 <0 Q DGIEN 33
  1669   "RTN","DGO THD1",45,0 )
  1670    ;create t he very fi rst 365 da ys clock
  1671   "RTN","DGO THD1",46,0 )
  1672    S DGIEN36 5=$$CR365C LK^DGOTHD2 (+DGIEN33, 1,DGSTRDT)
  1673   "RTN","DGO THD1",47,0 )
  1674    ;if error  then retu rn error
  1675   "RTN","DGO THD1",48,0 )
  1676    I DGIEN36 5<0 Q DGIE N365
  1677   "RTN","DGO THD1",49,0 )
  1678    ;create t he very fi rst 90 day s clock
  1679   "RTN","DGO THD1",50,0 )
  1680    S DGIEN90 =$$CR90CLK ^DGOTHD2(+ DGIEN33,+D GIEN365,1, DGSTRDT)
  1681   "RTN","DGO THD1",51,0 )
  1682    ;if error  then retu rn error
  1683   "RTN","DGO THD1",52,0 )
  1684    I DGIEN90 <0 Q DGIEN 90
  1685   "RTN","DGO THD1",53,0 )
  1686    Q 1
  1687   "RTN","DGO THD1",54,0 )
  1688    ;
  1689   "RTN","DGO THD1",55,0 )
  1690    ;Build 6  Sprint 3
  1691   "RTN","DGO THD1",56,0 )
  1692    ;DG*5.3*9 52
  1693   "RTN","DGO THD1",57,0 )
  1694    ;prompt f or EXPANDE D MH CARE  TYPE
  1695   "RTN","DGO THD1",58,0 )
  1696    ;called f rom input  template [ DG LOAD ED IT SCREEN  7]
  1697   "RTN","DGO THD1",59,0 )
  1698   XPANDED(DG DFN) ;
  1699   "RTN","DGO THD1",60,0 )
  1700    ;
  1701   "RTN","DGO THD1",61,0 )
  1702    ; Input :
  1703   "RTN","DGO THD1",62,0 )
  1704    ;  DGDFN  - Patient  IEN
  1705   "RTN","DGO THD1",63,0 )
  1706    ; Output:
  1707   "RTN","DGO THD1",64,0 )
  1708    ;  1. Dis play warni ng message  related t o the pati ent's
  1709   "RTN","DGO THD1",65,0 )
  1710    ;     pri mary eligi bility cod e EXPANDED  MH CARE N ON-VETERAN S
  1711   "RTN","DGO THD1",66,0 )
  1712    ;     and  its 90-Da y clock st atus
  1713   "RTN","DGO THD1",67,0 )
  1714    ;  2. Cre ate a new  entry in f ield #.550 1 node #.5 5 in Patie nt File (# 2)
  1715   "RTN","DGO THD1",68,0 )
  1716    ;  3. Cre ate 365-Da y and 90-D ay Countdo wn clock i n file #33
  1717   "RTN","DGO THD1",69,0 )
  1718    ;
  1719   "RTN","DGO THD1",70,0 )
  1720    Q:'$G(DGD FN)
  1721   "RTN","DGO THD1",71,0 )
  1722    N EMHCNV, DGMSG,DGQU IT,DGARR,D GIEN33,DGC LCK,DGLS36 5D,DGLS365 I,DGPTST
  1723   "RTN","DGO THD1",72,0 )
  1724    S EMHCNV= $$ISOTHD^D GOTHD(DGDF N)  ;check  if primar y eligibil ity is EXP ANDED MH C ARE NON-VE TERANS
  1725   "RTN","DGO THD1",73,0 )
  1726    Q:'EMHCNV
  1727   "RTN","DGO THD1",74,0 )
  1728    ;display  EXPANDED M H CARE  wa rning
  1729   "RTN","DGO THD1",75,0 )
  1730    S DGMSG(1 )="  "
  1731   "RTN","DGO THD1",76,0 )
  1732    S DGMSG(2 )="  This  code is us ed ONLY fo r Other Th an Honorab le veteran s seeking"
  1733   "RTN","DGO THD1",77,0 )
  1734    S DGMSG(3 )="  emerg ent mental  healthcar e prior to  VBA ADJUD ICATION."
  1735   "RTN","DGO THD1",78,0 )
  1736    S DGMSG(4 )="  "
  1737   "RTN","DGO THD1",79,0 )
  1738    D EN^DDIO L(.DGMSG)
  1739   "RTN","DGO THD1",80,0 )
  1740    ;check if  patient's  clock has  been prev iously adj udicated/i nactivated
  1741   "RTN","DGO THD1",81,0 )
  1742    I $D(^DGO TH(33,"B", DGDFN)) S  DGIEN33=$$ HASCLOCK^D GOTHD2(DGD FN) D  Q:D GQUIT'=1
  1743   "RTN","DGO THD1",82,0 )
  1744    . D GETS^ DIQ(33,DGI EN33_","," .01;.02;.0 3;.06;1*", "IE","DGAR R")
  1745   "RTN","DGO THD1",83,0 )
  1746    . S DGPTS T=$$STATUS ^DGOTHRI(. DGARR) ;OT H patient  clock stat us
  1747   "RTN","DGO THD1",84,0 )
  1748    . D CLOCK ^DGOTHRP2( DGIEN33)
  1749   "RTN","DGO THD1",85,0 )
  1750    . I '$$GE T1^DIQ(33, DGIEN33_", ",.02,"I")  D  Q:DGQU IT'=1
  1751   "RTN","DGO THD1",86,0 )
  1752    . . ;disp lay patien t's clock  status
  1753   "RTN","DGO THD1",87,0 )
  1754    . . D WAR N2(DGDFN,. DGARR)
  1755   "RTN","DGO THD1",88,0 )
  1756    . . ;do n ot allow u ser to re- enter EXPA NDED MH CA RE NON-VET ERANS if a lready adj udicated
  1757   "RTN","DGO THD1",89,0 )
  1758    . . I +$G (DGARR(33, DGIEN33_", ",.06,"I") ) D  Q
  1759   "RTN","DGO THD1",90,0 )
  1760    . . . W ! ,"  >>> Co ntact your  superviso r if you w ant to pro ceed this  action.",!
  1761   "RTN","DGO THD1",91,0 )
  1762    . . . D P REVSEL(DGD FN)
  1763   "RTN","DGO THD1",92,0 )
  1764    . . . S D GQUIT=0
  1765   "RTN","DGO THD1",93,0 )
  1766    . . S DGQ UIT=$$YESN O^DGOTHD2( "Do you wa nt to cont inue editi ng patient 's primary  eligibili ty code (Y /N)",,1) W  !
  1767   "RTN","DGO THD1",94,0 )
  1768    . . ;put  back the p revious pr imary elig ibility co de of the  patient
  1769   "RTN","DGO THD1",95,0 )
  1770    . . D:DGQ UIT'=1 PRE VSEL(DGDFN )
  1771   "RTN","DGO THD1",96,0 )
  1772    . S DGQUI T=1
  1773   "RTN","DGO THD1",97,0 )
  1774    ;
  1775   "RTN","DGO THD1",98,0 )
  1776    ;prompt f or EXPANDE D MH CARE  TYPE
  1777   "RTN","DGO THD1",99,0 )
  1778    ;Create a  new entry  in field  #.5501 nod e #.55 in  Patient Fi le (#2)
  1779   "RTN","DGO THD1",100, 0)
  1780    ;DGEMHC =  0   No en try create d
  1781   "RTN","DGO THD1",101, 0)
  1782    ;DGEMHC =  1   Creat e/Change E XPANDED MH  CARE TYPE  entry
  1783   "RTN","DGO THD1",102, 0)
  1784    N DGEMHC
  1785   "RTN","DGO THD1",103, 0)
  1786    S DGEMHC= $$EMHCTYP( DGDFN)
  1787   "RTN","DGO THD1",104, 0)
  1788    D:DGEMHC  UPDTEMHT(D GDFN)
  1789   "RTN","DGO THD1",105, 0)
  1790    K DGARR
  1791   "RTN","DGO THD1",106, 0)
  1792    ;Create 3 65-Day and  90-Day Co untdown cl ock in fil e #33
  1793   "RTN","DGO THD1",107, 0)
  1794    D STRDATE ^DGOTHD(DG DFN)
  1795   "RTN","DGO THD1",108, 0)
  1796    Q
  1797   "RTN","DGO THD1",109, 0)
  1798    ;
  1799   "RTN","DGO THD1",110, 0)
  1800   EMHCTYP(DG DFN) ;prom pt for EXP ANDED MH C ARE TYPE
  1801   "RTN","DGO THD1",111, 0)
  1802    ;field #. 5501 node  #.55 in Pa tient File  (#2)
  1803   "RTN","DGO THD1",112, 0)
  1804    ; Input :
  1805   "RTN","DGO THD1",113, 0)
  1806    ;  DGDFN  - Patient  IEN
  1807   "RTN","DGO THD1",114, 0)
  1808    ; Output:
  1809   "RTN","DGO THD1",115, 0)
  1810    ;  0 - No  entry cre ated
  1811   "RTN","DGO THD1",116, 0)
  1812    ;  1 - Cr eate/Chang e EXPANDED  MH CARE T YPE entry
  1813   "RTN","DGO THD1",117, 0)
  1814    ;
  1815   "RTN","DGO THD1",118, 0)
  1816    N DA,DGDI RB,DGDEL,D GMSG,DIR,D TOUT,DUOUT ,DIROUT,DI RUT
  1817   "RTN","DGO THD1",119, 0)
  1818    N DGRSN,D ONE,FILE,F IELD
  1819   "RTN","DGO THD1",120, 0)
  1820    S FILE=2, FIELD=.550 1,DGDEL=0
  1821   "RTN","DGO THD1",121, 0)
  1822    S DIR(0)= FILE_","_F IELD_"AO", DONE=0 S:D GDFN DA=DG DFN
  1823   "RTN","DGO THD1",122, 0)
  1824    S DGDIRB= $$GET1^DIQ (2,DFN_"," ,.5501,"I" )
  1825   "RTN","DGO THD1",123, 0)
  1826    I DGDIRB= "OTH-90",$ $GET1^DIQ( 33,$$HASCL OCK^DGOTHD 2(DGDFN)_" ,",.02,"I" ) S DGDEL= 1
  1827   "RTN","DGO THD1",124, 0)
  1828    S DIR("B" )=$S(DGDIR B'="":$$OT HSOC^DGOTH D1(DGDIRB) ,1:"EMERGE NT MH OTH" )
  1829   "RTN","DGO THD1",125, 0)
  1830    F  D  Q:D ONE
  1831   "RTN","DGO THD1",126, 0)
  1832    . ;keep p rompting u ntil user  enter a va lid entry
  1833   "RTN","DGO THD1",127, 0)
  1834    . D ^DIR
  1835   "RTN","DGO THD1",128, 0)
  1836    . I $D(DT OUT) D PRE VSEL(DGDFN ) S DONE=1  Q  ;remov e primary  EXPANDED i f in EXPAN DED MH CAR E TYPE pro mpt timed- out
  1837   "RTN","DGO THD1",129, 0)
  1838    . I $D(DU OUT)!$D(DI ROUT) W !, "  Exit no t allowed.  This is a  required  response.? ?",! Q
  1839   "RTN","DGO THD1",130, 0)
  1840    . I $D(DI RUT) D  Q
  1841   "RTN","DGO THD1",131, 0)
  1842    . . I DGD EL D DELMS G(DGDFN,DG DIRB,1) Q
  1843   "RTN","DGO THD1",132, 0)
  1844    . . W !,"   No Expan ded MH Car e Type fou nd."
  1845   "RTN","DGO THD1",133, 0)
  1846    . . W !,"   Nothing  to delete. ",!
  1847   "RTN","DGO THD1",134, 0)
  1848    . ;
  1849   "RTN","DGO THD1",135, 0)
  1850    . I Y'="O TH-90",DGD EL D WARN1  Q
  1851   "RTN","DGO THD1",136, 0)
  1852    . ;prompt  for the r eason why  user react ivate pati ent's 90-d ay clock
  1853   "RTN","DGO THD1",137, 0)
  1854    . W !
  1855   "RTN","DGO THD1",138, 0)
  1856    . I Y="OT H-90",$$HA SCLOCK^DGO THD2(DGDFN ),'$$GET1^ DIQ(33,$$H ASCLOCK^DG OTHD2(DGDF N)_",",.02 ,"I") D  Q
  1857   "RTN","DGO THD1",139, 0)
  1858    . . S DGR SN=$$REASO N(2)
  1859   "RTN","DGO THD1",140, 0)
  1860    . . D INR E(DGRSN,2)
  1861   "RTN","DGO THD1",141, 0)
  1862    . S (DONE ,DGQUIT)=1
  1863   "RTN","DGO THD1",142, 0)
  1864    K DIR
  1865   "RTN","DGO THD1",143, 0)
  1866    Q DGQUIT
  1867   "RTN","DGO THD1",144, 0)
  1868    ;
  1869   "RTN","DGO THD1",145, 0)
  1870   UPDTEMHT(D GDFN) ;set  the assoc iated EXPA NDED MH CA RE TYPE
  1871   "RTN","DGO THD1",146, 0)
  1872    N DGFDA
  1873   "RTN","DGO THD1",147, 0)
  1874    I $$CHCKP AT^DGOTHD2 (DGDFN)'>0  Q -2  ;pa tient does  not exist
  1875   "RTN","DGO THD1",148, 0)
  1876    S DGFDA(2 ,DGDFN_"," ,.5501)=Y
  1877   "RTN","DGO THD1",149, 0)
  1878    D FILE^DI E("K","DGF DA","DGERR ")
  1879   "RTN","DGO THD1",150, 0)
  1880    Q
  1881   "RTN","DGO THD1",151, 0)
  1882    ;
  1883   "RTN","DGO THD1",152, 0)
  1884   OTHSOC(EMH CT) ;Extra ct OTHER T HAN HONORA BLE set of  codes
  1885   "RTN","DGO THD1",153, 0)
  1886    ;
  1887   "RTN","DGO THD1",154, 0)
  1888    ; Input :  EMHCT - T he interna l set of c ode value
  1889   "RTN","DGO THD1",155, 0)
  1890    ; Output:  The exter nal set of  code valu e
  1891   "RTN","DGO THD1",156, 0)
  1892    ;
  1893   "RTN","DGO THD1",157, 0)
  1894    N DGERR,I ,DGOTHSOC, YY
  1895   "RTN","DGO THD1",158, 0)
  1896    S DGOTHSO C=$$GET1^D ID(2,.5501 ,,"SET OF  CODES",,"D GERR")
  1897   "RTN","DGO THD1",159, 0)
  1898    Q:$D(DGER R)
  1899   "RTN","DGO THD1",160, 0)
  1900    F I=1:1:$ L(DGOTHSOC ,";") S YY =$P(DGOTHS OC,";",I)  Q:YY=""  S  DGOTHSOC( $P(YY,":") )=$P(YY,": ",2)
  1901   "RTN","DGO THD1",161, 0)
  1902    Q DGOTHSO C(EMHCT)
  1903   "RTN","DGO THD1",162, 0)
  1904    ;
  1905   "RTN","DGO THD1",163, 0)
  1906   EMHCT(DGDF N) ;EXPAND ED MH CARE  TYPE 'OTH ' in Patie nt file #2
  1907   "RTN","DGO THD1",164, 0)
  1908    Q:'$G(DGD FN)
  1909   "RTN","DGO THD1",165, 0)
  1910    N DGFDART ,DGOTHERR
  1911   "RTN","DGO THD1",166, 0)
  1912    S DGFDART ($J,2,DGDF N_",",.550 1)=""
  1913   "RTN","DGO THD1",167, 0)
  1914    D FILE^DI E("U","DGF DART($J)", "DGOTHERR" )
  1915   "RTN","DGO THD1",168, 0)
  1916    I $D(DGOT HERR) W !! ,"An error  occurred  during fil ing."
  1917   "RTN","DGO THD1",169, 0)
  1918    Q
  1919   "RTN","DGO THD1",170, 0)
  1920    ;
  1921   "RTN","DGO THD1",171, 0)
  1922   PREVSEL(DG DFN) ;put  back the p atient's p revious pr imary elig ibility co de
  1923   "RTN","DGO THD1",172, 0)
  1924    N DGFDART ,DGOTHERR
  1925   "RTN","DGO THD1",173, 0)
  1926    S DGFDART ($J,2,DGDF N_",",.361 )=$S(DGPRV SEL>0:DGPR VSEL,1:"")
  1927   "RTN","DGO THD1",174, 0)
  1928    D FILE^DI E("U","DGF DART($J)", "DGOTHERR" )
  1929   "RTN","DGO THD1",175, 0)
  1930    I $D(DGOT HERR) W !! ,"An error  occurred  during fil ing."
  1931   "RTN","DGO THD1",176, 0)
  1932    Q
  1933   "RTN","DGO THD1",177, 0)
  1934    ;
  1935   "RTN","DGO THD1",178, 0)
  1936   EMHELG(DGD FN) ;Is EX PANDE MH C ARE NON-VE TERANS the  patient's  primary e ligibility ?
  1937   "RTN","DGO THD1",179, 0)
  1938    ; Input :
  1939   "RTN","DGO THD1",180, 0)
  1940    ;    DGDF N - Patien t IEN
  1941   "RTN","DGO THD1",181, 0)
  1942    ; Returne d: 
  1943   "RTN","DGO THD1",182, 0)
  1944    ;    1      - Yes (P rim Eligib ility = EX PANDE MH C ARE NON-VE TERANS)
  1945   "RTN","DGO THD1",183, 0)
  1946    ;    0      - No
  1947   "RTN","DGO THD1",184, 0)
  1948    ;
  1949   "RTN","DGO THD1",185, 0)
  1950    Q $P($G(^ DIC(8,+$G( ^DPT(+$G(D FN),.36)), 0)),"^",9) =23
  1951   "RTN","DGO THD1",186, 0)
  1952    ;
  1953   "RTN","DGO THD1",187, 0)
  1954   REASON(COD E) ;prompt  user to p rovide rea son for in activating  or reacti vating the  clock
  1955   "RTN","DGO THD1",188, 0)
  1956    ;CODE:
  1957   "RTN","DGO THD1",189, 0)
  1958    ; 1 for I NACTIVATIO N 0
  1959   "RTN","DGO THD1",190, 0)
  1960    ; 2 for R EACTIVATIO N 1
  1961   "RTN","DGO THD1",191, 0)
  1962    N DGRSN
  1963   "RTN","DGO THD1",192, 0)
  1964    S DGRSN=$ $ANSWER^DG OTHRPT("Pl ease provi de reason  for "_$S(C ODE=1:"INA CTIVATION" ,1:"REACTI VATION")_"  (Required )","","F^5 :60^K:X=""  ""!(X=""" ")!(X?1E)  X","^D HEL P^DGOTHRI( 5)")
  1965   "RTN","DGO THD1",193, 0)
  1966    Q $S(DGRS N=-1:"",1: DGRSN)
  1967   "RTN","DGO THD1",194, 0)
  1968    ;
  1969   "RTN","DGO THD1",195, 0)
  1970   INRE(DGRSN ,CODE) ;in activate/r eactivate  90-Day clo ck
  1971   "RTN","DGO THD1",196, 0)
  1972    I DGRSN=" " D  Q
  1973   "RTN","DGO THD1",197, 0)
  1974    . S DONE= 1,DGQUIT=0
  1975   "RTN","DGO THD1",198, 0)
  1976    . W !!,"   No Reason  Provided.  <NO ACTIO N TAKEN>", !
  1977   "RTN","DGO THD1",199, 0)
  1978    . I CODE> 1 D PREVSE L(DGDFN)
  1979   "RTN","DGO THD1",200, 0)
  1980    ;inactiva te clock
  1981   "RTN","DGO THD1",201, 0)
  1982    D STRE^DG OTHRI(DGIE N33,"",.DG ARR,DGLS36 5I,DGCLCK, $S(CODE=1: 0,1:1),DGR SN,"",DGPT ST)
  1983   "RTN","DGO THD1",202, 0)
  1984    S (DONE,D GQUIT)=1
  1985   "RTN","DGO THD1",203, 0)
  1986    W !!,"  T his patien t 90-Day c ountdown c lock is "_ $S(CODE=1: "INACTIVAT ED",1:"REA CTIVATED") ,!
  1987   "RTN","DGO THD1",204, 0)
  1988    Q
  1989   "RTN","DGO THD1",205, 0)
  1990    ;
  1991   "RTN","DGO THD1",206, 0)
  1992   DELMSG(DGD FN,DGDIRB, CODE) ;Del ete or cha nging not  allowed
  1993   "RTN","DGO THD1",207, 0)
  1994    S DGMSG(1 )="  "
  1995   "RTN","DGO THD1",208, 0)
  1996    S DGMSG(2 )="  Expan ded MH Car e Type '"_ $$OTHSOC^D GOTHD1(DGD IRB)_"' ca n't be "_$ S(CODE=1:" deleted",1 :"changed" )_"."
  1997   "RTN","DGO THD1",209, 0)
  1998    S DGMSG(3 )=$$MSG90( )
  1999   "RTN","DGO THD1",210, 0)
  2000    S DGMSG(4 )="  "
  2001   "RTN","DGO THD1",211, 0)
  2002    D EN^DDIO L(.DGMSG)
  2003   "RTN","DGO THD1",212, 0)
  2004    K DGMSG
  2005   "RTN","DGO THD1",213, 0)
  2006    Q
  2007   "RTN","DGO THD1",214, 0)
  2008    ;
  2009   "RTN","DGO THD1",215, 0)
  2010   MSG90() ;w arning mes sage fo 90 -Day
  2011   "RTN","DGO THD1",216, 0)
  2012    Q "  This  patient c urrently h as an ACTI VE 90-Day  countdown  clock."
  2013   "RTN","DGO THD1",217, 0)
  2014    ;
  2015   "RTN","DGO THD1",218, 0)
  2016   WARN1 ;War n user abo ut the sta tus of the  patient O TH clock
  2017   "RTN","DGO THD1",219, 0)
  2018    S DGOTHMS G(1)="  "
  2019   "RTN","DGO THD1",220, 0)
  2020    S DGOTHMS G(2)=$$MSG 90()
  2021   "RTN","DGO THD1",221, 0)
  2022    S DGOTHMS G(3)="  Pl ease inact ivate the  clock via  ""Inactiva te or Reac tivate OTH "
  2023   "RTN","DGO THD1",222, 0)
  2024    S DGOTHMS G(4)="  Pt  Countdown  Clock"" o ption."
  2025   "RTN","DGO THD1",223, 0)
  2026    S DGOTHMS G(5)="  "
  2027   "RTN","DGO THD1",224, 0)
  2028    D EN^DDIO L(.DGOTHMS G,"","!")
  2029   "RTN","DGO THD1",225, 0)
  2030    Q
  2031   "RTN","DGO THD1",226, 0)
  2032    ;
  2033   "RTN","DGO THD1",227, 0)
  2034   WARN2(DGDF N,DGARR) ;
  2035   "RTN","DGO THD1",228, 0)
  2036    N DGIEN33
  2037   "RTN","DGO THD1",229, 0)
  2038    S DGIEN33 =$$HASCLOC K^DGOTHD2( DGDFN)_","
  2039   "RTN","DGO THD1",230, 0)
  2040    S DGOTHMS G(1)="  Pa tient's 90 -Day count down clock  was previ ously "_$S (+$G(DGARR (33,DGIEN3 3,.06,"I") ):"ADJUDIC ATED",1:"I NACTIVATED ")
  2041   "RTN","DGO THD1",231, 0)
  2042    S DGOTHMS G(2)="  on : "_$S(+$G (DGARR(33, DGIEN33,.0 3,"I")):$$ FMTE^XLFDT (DGARR(33, DGIEN33,.0 3,"I")),1: $$FMTE^XLF DT(DGARR(3 3,DGIEN33, .06,"I")))
  2043   "RTN","DGO THD1",232, 0)
  2044    S DGOTHMS G(3)="  "
  2045   "RTN","DGO THD1",233, 0)
  2046    D EN^DDIO L(.DGOTHMS G,"","!")
  2047   "RTN","DGO THD1",234, 0)
  2048    Q
  2049   "RTN","DGO THD1",235, 0)
  2050    ;
  2051   "RTN","DGO THD1",236, 0)
  2052   TRUE() ;de cide if pr imary elig ibilty cod e will be  deleted
  2053   "RTN","DGO THD1",237, 0)
  2054    I DFN'=DA ,$P($G(^DI C(8,DA,0)) ,"^",9)=23  Q 1
  2055   "RTN","DGO THD1",238, 0)
  2056    Q 0
  2057   "RTN","DGO THD1",239, 0)
  2058    ;
  2059   "RTN","DGO THD2")
  2060   0^5^B18967 6030
  2061   "RTN","DGO THD2",1,0)
  2062   DGOTHD2 ;S LC/SS,RM,R ED - OTHD  (OTHER THA N HONORABL E DISCHARG E) APIs ;1 2/27/17
  2063   "RTN","DGO THD2",2,0)
  2064    ;;5.3;Reg istration; **952**;Au g 13, 1993 ;Build 68
  2065   "RTN","DGO THD2",3,0)
  2066    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  2067   "RTN","DGO THD2",4,0)
  2068    ;     Las t Edited:  SHRPE/RED  - May 2, 2 018 15:11
  2069   "RTN","DGO THD2",5,0)
  2070    ;
  2071   "RTN","DGO THD2",6,0)
  2072    ;  IA:  1 0103   ^XL FDT (suppo rted)  - [ $$FMADD^XL FDT, $$FMT E^XLFDT ,  $$NOW^XLFD T]
  2073   "RTN","DGO THD2",7,0)
  2074    ;       1 0015   ^DI Q   (suppo rted)  - [ GETS^DIQ]
  2075   "RTN","DGO THD2",8,0)
  2076    ;       1 0026   ^DI R   (suppo rted)
  2077   "RTN","DGO THD2",9,0)
  2078    ;         2053   ^DI E   (suppo rted)  - [ FILE^DIE,  UPDATE^DIE ]
  2079   "RTN","DGO THD2",10,0 )
  2080    ;       1 0000   ^%D TC  (suppo rted)  - [ NOW^%DTC]
  2081   "RTN","DGO THD2",11,0 )
  2082    Q
  2083   "RTN","DGO THD2",12,0 )
  2084    ;
  2085   "RTN","DGO THD2",13,0 )
  2086    ;create t he new OTH  clock
  2087   "RTN","DGO THD2",14,0 )
  2088    ;DGDFN -  patient's  IEN
  2089   "RTN","DGO THD2",15,0 )
  2090    ;returns 
  2091   "RTN","DGO THD2",16,0 )
  2092    ;IEN of t he file #3 3
  2093   "RTN","DGO THD2",17,0 )
  2094    ;or -1^er ror messag e
  2095   "RTN","DGO THD2",18,0 )
  2096   CROTHCLK(D GDFN) ;
  2097   "RTN","DGO THD2",19,0 )
  2098    N DGVALS, DGIEN33
  2099   "RTN","DGO THD2",20,0 )
  2100    I $$CHCKP AT(DGDFN)' >0 Q -2  ; patient do es not exi st
  2101   "RTN","DGO THD2",21,0 )
  2102    S DGVALS( .01)=DGDFN
  2103   "RTN","DGO THD2",22,0 )
  2104    S DGVALS( .02)=1 ;se t to ACTIV E
  2105   "RTN","DGO THD2",23,0 )
  2106    S DGIEN=$ $INSREC(33 ,"",.DGVAL S)
  2107   "RTN","DGO THD2",24,0 )
  2108    Q DGIEN
  2109   "RTN","DGO THD2",25,0 )
  2110    ;
  2111   "RTN","DGO THD2",26,0 )
  2112    ;create t he new 365  days cloc k
  2113   "RTN","DGO THD2",27,0 )
  2114    ;DGIEN33  - IEN of t he file #3 3
  2115   "RTN","DGO THD2",28,0 )
  2116    ;CLCKNO -  clock #
  2117   "RTN","DGO THD2",29,0 )
  2118    ;DGSTRDT  - start da te
  2119   "RTN","DGO THD2",30,0 )
  2120   CR365CLK(D GIEN33,CLC KNO,DGSTRD T) ;
  2121   "RTN","DGO THD2",31,0 )
  2122    N IEN365, DGVALS
  2123   "RTN","DGO THD2",32,0 )
  2124    S IEN365= $$CHCK365( DGIEN33,CL CKNO)
  2125   "RTN","DGO THD2",33,0 )
  2126    I IEN365< 0 Q -1  ;  OTH clock  entry in t he file #3 3 doesn't  exist
  2127   "RTN","DGO THD2",34,0 )
  2128    I IEN365> 0 Q -2  ;  this 365 c lock alrea dy exists
  2129   "RTN","DGO THD2",35,0 )
  2130    S DGVALS( .01)=CLCKN O
  2131   "RTN","DGO THD2",36,0 )
  2132    S DGVALS( .02)=DGSTR DT ;start  date
  2133   "RTN","DGO THD2",37,0 )
  2134    S DGIEN=$ $INSREC(33 .01,DGIEN3 3,.DGVALS)
  2135   "RTN","DGO THD2",38,0 )
  2136    Q DGIEN
  2137   "RTN","DGO THD2",39,0 )
  2138    ;
  2139   "RTN","DGO THD2",40,0 )
  2140    ;create t he new 90  days clock
  2141   "RTN","DGO THD2",41,0 )
  2142    ;DGIEN33      - ien  file #33
  2143   "RTN","DGO THD2",42,0 )
  2144    ;DGI3301      - ien  subfile #3 3.01
  2145   "RTN","DGO THD2",43,0 )
  2146    ;CLCKNO       - 90 d ays clock  #
  2147   "RTN","DGO THD2",44,0 )
  2148    ;DGSTRDT      - star t date, if  negative  or zero th en do not  set the st art date
  2149   "RTN","DGO THD2",45,0 )
  2150    ;DGAUDUZ      - user  entered t he authori zation
  2151   "RTN","DGO THD2",46,0 )
  2152    ;DGAUDT       - auth orization  date
  2153   "RTN","DGO THD2",47,0 )
  2154    ;DGAUTHRZ DBY - the  person who  approved  and author ized the 2 nd 90-Day  period
  2155   "RTN","DGO THD2",48,0 )
  2156   CR90CLK(DG IEN33,DGI3 301,CLCKNO ,DGSTRDT,D GAUDUZ,DGA UDT,DGAUTH RZDBY) ;
  2157   "RTN","DGO THD2",49,0 )
  2158    N IEN90,D GVALS
  2159   "RTN","DGO THD2",50,0 )
  2160    S IEN90=$ $CHCK90(DG IEN33,DGI3 301,CLCKNO )
  2161   "RTN","DGO THD2",51,0 )
  2162    I IEN90<0  Q -1  ; O TH clock e ntry in th e file #33  doesn't e xist
  2163   "RTN","DGO THD2",52,0 )
  2164    I IEN90>0  Q -2  ; t his 90 clo ck already  exists
  2165   "RTN","DGO THD2",53,0 )
  2166    S DGVALS( .01)=CLCKN O
  2167   "RTN","DGO THD2",54,0 )
  2168    I DGSTRDT >0 S DGVAL S(.02)=DGS TRDT ;star t date
  2169   "RTN","DGO THD2",55,0 )
  2170    I $G(DGAU DUZ)>0 S D GVALS(.03) =+DGAUDUZ  ;the user  entered th e authoriz ation
  2171   "RTN","DGO THD2",56,0 )
  2172    S DGVALS( .05)=$S($G (DUZ)>0:$$ GET1^DIQ(2 00,DUZ,.01 ),1:"POSTM ASTER") ;t he user na me, otherw ise - POST MASTER
  2173   "RTN","DGO THD2",57,0 )
  2174    S DGVALS( .06)=$$DT^ XLFDT ;now
  2175   "RTN","DGO THD2",58,0 )
  2176    I $D(DGAU THRZDBY) S  DGVALS(.0 7)=DGAUTHR ZDBY ;Auth orized By
  2177   "RTN","DGO THD2",59,0 )
  2178    S DGVALS( .08)=$$GET SITE(.DUZ)   ;get the  user's cu rrent faci lity numbe r
  2179   "RTN","DGO THD2",60,0 )
  2180    S DGIEN=$ $INSREC(33 .11,DGI330 1_","_DGIE N33,.DGVAL S)
  2181   "RTN","DGO THD2",61,0 )
  2182    Q DGIEN
  2183   "RTN","DGO THD2",62,0 )
  2184    ;
  2185   "RTN","DGO THD2",63,0 )
  2186    ;Get the  user's cur rent facil ity number .  If not  found, it  will
  2187   "RTN","DGO THD2",64,0 )
  2188    ;return t he facilit y number o f the prim ary facili ty.
  2189   "RTN","DGO THD2",65,0 )
  2190   GETSITE(DU Z) ;
  2191   "RTN","DGO THD2",66,0 )
  2192    ;Input:
  2193   "RTN","DGO THD2",67,0 )
  2194    ;      DU Z array, p ass by ref erence
  2195   "RTN","DGO THD2",68,0 )
  2196    ;Output:
  2197   "RTN","DGO THD2",69,0 )
  2198    ;      Fu nction Val ue - facil ity number
  2199   "RTN","DGO THD2",70,0 )
  2200    N FACILIT Y
  2201   "RTN","DGO THD2",71,0 )
  2202    S FACILIT Y=""
  2203   "RTN","DGO THD2",72,0 )
  2204    S:DUZ'=.5  FACILITY= DUZ(2)
  2205   "RTN","DGO THD2",73,0 )
  2206    I 'FACILI TY S FACIL ITY=+$$SIT E^VASITE()
  2207   "RTN","DGO THD2",74,0 )
  2208    Q FACILIT Y
  2209   "RTN","DGO THD2",75,0 )
  2210    ;
  2211   "RTN","DGO THD2",76,0 )
  2212    ;check if  the patie nt has 2nd  period au thorizatio n
  2213   "RTN","DGO THD2",77,0 )
  2214    ;DGIEN33  - ien file  #33
  2215   "RTN","DGO THD2",78,0 )
  2216    ;DGI3301  - ien subf ile #33.01
  2217   "RTN","DGO THD2",79,0 )
  2218    ;CLCKNO -  90 days c lock #
  2219   "RTN","DGO THD2",80,0 )
  2220   HAS2AUTH(D GIEN33,DGI 3301,CLCKN O) ;
  2221   "RTN","DGO THD2",81,0 )
  2222    N DGIEN90 ,DGRETDAT
  2223   "RTN","DGO THD2",82,0 )
  2224    S DGIEN90 =$$CHCK90( DGIEN33,DG I3301,CLCK NO)
  2225   "RTN","DGO THD2",83,0 )
  2226    I DGIEN90 '>0 Q -1   ; OTH cloc k entry in  the file  #33 doesn' t exist
  2227   "RTN","DGO THD2",84,0 )
  2228    S DGRETDA T=$G(^DGOT H(33,DGIEN 33,1,DGI33 01,1,DGIEN 90,0))
  2229   "RTN","DGO THD2",85,0 )
  2230    Q $P(DGRE TDAT,U,3,4 )
  2231   "RTN","DGO THD2",86,0 )
  2232    ;
  2233   "RTN","DGO THD2",87,0 )
  2234    ;does the  patient h ave clock?
  2235   "RTN","DGO THD2",88,0 )
  2236    ;DGDFN -  patient IE N
  2237   "RTN","DGO THD2",89,0 )
  2238   HASCLOCK(D GDFN) ;
  2239   "RTN","DGO THD2",90,0 )
  2240    Q +$O(^DG OTH(33,"B" ,DGDFN,0))
  2241   "RTN","DGO THD2",91,0 )
  2242    ;
  2243   "RTN","DGO THD2",92,0 )
  2244    ;how many  365 days  clock the  patient ha s?
  2245   "RTN","DGO THD2",93,0 )
  2246    ;DGIEN33  - ien of # 33
  2247   "RTN","DGO THD2",94,0 )
  2248   CLCKS365(D GIEN33) ;
  2249   "RTN","DGO THD2",95,0 )
  2250    Q $O(^DGO TH(33,DGIE N33,1,"B", 99),-1)
  2251   "RTN","DGO THD2",96,0 )
  2252    ;
  2253   "RTN","DGO THD2",97,0 )
  2254    ;returns 
  2255   "RTN","DGO THD2",98,0 )
  2256    ;-1 : if  OTH clock  entry in t he file #3 3 doesn't  exist
  2257   "RTN","DGO THD2",99,0 )
  2258    ;0  : if  365 days c lock with  the number  CLCKNO do esn't exis t
  2259   "RTN","DGO THD2",100, 0)
  2260    ;>0 : IEN  of the 36 5 days clo ck with th e number C LCKNO
  2261   "RTN","DGO THD2",101, 0)
  2262   CHCK365(DG IEN33,CLCK NO) ;
  2263   "RTN","DGO THD2",102, 0)
  2264    I +$D(^DG OTH(33,DGI EN33,0))'> 0 Q -1  ;c lock doesn 't exist
  2265   "RTN","DGO THD2",103, 0)
  2266    Q +$O(^DG OTH(33,DGI EN33,1,"B" ,CLCKNO,0) )
  2267   "RTN","DGO THD2",104, 0)
  2268    ;
  2269   "RTN","DGO THD2",105, 0)
  2270    ;returns 
  2271   "RTN","DGO THD2",106, 0)
  2272    ;-1 : if  OTH clock  entry in t he file #3 3 doesn't  exist
  2273   "RTN","DGO THD2",107, 0)
  2274    ;0  : if  90 days cl ock with t he number  CLCKNO doe sn't exist
  2275   "RTN","DGO THD2",108, 0)
  2276    ;>0 : IEN  of the 90  days cloc k with the  number CL CKNO
  2277   "RTN","DGO THD2",109, 0)
  2278   CHCK90(DGI EN33,DGI33 01,CLCKNO)  ;
  2279   "RTN","DGO THD2",110, 0)
  2280    I +$D(^DG OTH(33,DGI EN33,0))'> 0 Q -1  ;c lock doesn 't exist
  2281   "RTN","DGO THD2",111, 0)
  2282    I +$D(^DG OTH(33,DGI EN33,1,DGI 3301,0))'> 0 Q -1  ;c lock doesn 't exist
  2283   "RTN","DGO THD2",112, 0)
  2284    Q +$O(^DG OTH(33,DGI EN33,1,DGI 3301,1,"B" ,CLCKNO,0) )
  2285   "RTN","DGO THD2",113, 0)
  2286    ;check DF N
  2287   "RTN","DGO THD2",114, 0)
  2288   CHCKPAT(DG DFN) ;
  2289   "RTN","DGO THD2",115, 0)
  2290    Q +$D(^DP T(DGDFN,0) )
  2291   "RTN","DGO THD2",116, 0)
  2292    ;
  2293   "RTN","DGO THD2",117, 0)
  2294    ;get pati ent IEN by  ien of th e file #33
  2295   "RTN","DGO THD2",118, 0)
  2296   GETPAT(DGI EN33) ;
  2297   "RTN","DGO THD2",119, 0)
  2298    Q $P($G(^ DGOTH(33,D GIEN33,0)) ,U)
  2299   "RTN","DGO THD2",120, 0)
  2300    ;
  2301   "RTN","DGO THD2",121, 0)
  2302    ;input:
  2303   "RTN","DGO THD2",122, 0)
  2304    ;DGPROM -  prompt te xt
  2305   "RTN","DGO THD2",123, 0)
  2306    ;DGDFVL -  default v alue (opti onal)
  2307   "RTN","DGO THD2",124, 0)
  2308    ;returns:
  2309   "RTN","DGO THD2",125, 0)
  2310    ; "respon se^"
  2311   "RTN","DGO THD2",126, 0)
  2312   PROMPT(DGP ROM,DGDFVL ) ;
  2313   "RTN","DGO THD2",127, 0)
  2314    N DGRET,D IR,X,Y,DIR UT,DIROUT, DTOUT,DUOU T
  2315   "RTN","DGO THD2",128, 0)
  2316    S DGRET=" ^"
  2317   "RTN","DGO THD2",129, 0)
  2318    S DIR(0)= "F^::2",DI R("A")=DGP ROM
  2319   "RTN","DGO THD2",130, 0)
  2320    I $L($G(D GDFVL))>0  S DIR("B") =$G(DGDFVL )
  2321   "RTN","DGO THD2",131, 0)
  2322    D ^DIR I  $D(DIRUT)  Q "^"
  2323   "RTN","DGO THD2",132, 0)
  2324    S $P(DGRE T,U)=Y
  2325   "RTN","DGO THD2",133, 0)
  2326    Q DGRET
  2327   "RTN","DGO THD2",134, 0)
  2328    ;
  2329   "RTN","DGO THD2",135, 0)
  2330   ASKDT(DGPR OM,DGDFVL, DGDIR0,DGL VL) ;
  2331   "RTN","DGO THD2",136, 0)
  2332    ;  Input:
  2333   "RTN","DGO THD2",137, 0)
  2334    ;   DGPRO M - prompt  text
  2335   "RTN","DGO THD2",138, 0)
  2336    ;   DGDFV L - defaul t value (o ptional)
  2337   "RTN","DGO THD2",139, 0)
  2338    ;   DGDIR O - DIR(0)  string
  2339   "RTN","DGO THD2",140, 0)
  2340    ;   DGLVL
  2341   "RTN","DGO THD2",141, 0)
  2342    ;       1   - if the  question  comes from  the 1st 9 0-day ques tion
  2343   "RTN","DGO THD2",142, 0)
  2344    ;       2   - if the  question  comes from  the 2nd 9 0-day ques tion
  2345   "RTN","DGO THD2",143, 0)
  2346    ;  Output :
  2347   "RTN","DGO THD2",144, 0)
  2348    ;   Funct ion value  - Internal  value ret urned from  ^DIR
  2349   "RTN","DGO THD2",145, 0)
  2350    ;
  2351   "RTN","DGO THD2",146, 0)
  2352    N DIR,DIR UT,DIROUT, DUOUT,DTOU T,XX,Y
  2353   "RTN","DGO THD2",147, 0)
  2354    S DIR(0)= DGDIR0
  2355   "RTN","DGO THD2",148, 0)
  2356    S DIR("A" )=DGPROM
  2357   "RTN","DGO THD2",149, 0)
  2358    S DIR("B" )=DGDFVL
  2359   "RTN","DGO THD2",150, 0)
  2360    I DGLVL=1  D
  2361   "RTN","DGO THD2",151, 0)
  2362    . S DIR(" ?")="^D HE LP3^DGOTHD 2"
  2363   "RTN","DGO THD2",152, 0)
  2364    . S DIR(" ??")=DIR(" ?")
  2365   "RTN","DGO THD2",153, 0)
  2366    I DGLVL=2  D
  2367   "RTN","DGO THD2",154, 0)
  2368    . S DIR(" ?")="^D HE LP1^DGOTHD 2"
  2369   "RTN","DGO THD2",155, 0)
  2370    . S DIR(" ??")="^D H ELP2^DGOTH D2"
  2371   "RTN","DGO THD2",156, 0)
  2372    D ^DIR
  2373   "RTN","DGO THD2",157, 0)
  2374    Q:$D(DUOU T)!($D(DTO UT)) "^"
  2375   "RTN","DGO THD2",158, 0)
  2376    Q $S(X="@ ":"@",1:Y\ 1)
  2377   "RTN","DGO THD2",159, 0)
  2378    ;Q Y\1
  2379   "RTN","DGO THD2",160, 0)
  2380    ;
  2381   "RTN","DGO THD2",161, 0)
  2382    ;
  2383   "RTN","DGO THD2",162, 0)
  2384    ; Ask
  2385   "RTN","DGO THD2",163, 0)
  2386    ; Input:
  2387   "RTN","DGO THD2",164, 0)
  2388    ;  DGQSTR  - questio n
  2389   "RTN","DGO THD2",165, 0)
  2390    ;  DGDFL  - default  answer
  2391   "RTN","DGO THD2",166, 0)
  2392    ;  DGLVL
  2393   "RTN","DGO THD2",167, 0)
  2394    ;     1   - if the q uestion co mes from a uthorizing  the oth c lock
  2395   "RTN","DGO THD2",168, 0)
  2396    ;     2   - if the q uestion co mes from s tarting th e oth cloc k
  2397   "RTN","DGO THD2",169, 0)
  2398    ; Output:  
  2399   "RTN","DGO THD2",170, 0)
  2400    ; 1 YES
  2401   "RTN","DGO THD2",171, 0)
  2402    ; 0 NO
  2403   "RTN","DGO THD2",172, 0)
  2404    ; -1 if c ancelled
  2405   "RTN","DGO THD2",173, 0)
  2406   YESNO(DGQS TR,DGDFL,D GLVL) ; De fault - YE S
  2407   "RTN","DGO THD2",174, 0)
  2408    N DIR,Y,D UOUT,DIROU T,DIRUT,DT OUT
  2409   "RTN","DGO THD2",175, 0)
  2410    S DIR(0)= "Y"
  2411   "RTN","DGO THD2",176, 0)
  2412    S DIR("A" )=DGQSTR
  2413   "RTN","DGO THD2",177, 0)
  2414    I DGLVL=2  S DIR("A" ,1)=""
  2415   "RTN","DGO THD2",178, 0)
  2416    S:$L($G(D GDFL)) DIR ("B")=DGDF L
  2417   "RTN","DGO THD2",179, 0)
  2418    D ^DIR
  2419   "RTN","DGO THD2",180, 0)
  2420    Q $S($G(D UOUT)!$G(D UOUT)!(Y=" ^"):-1,1:Y )
  2421   "RTN","DGO THD2",181, 0)
  2422    ;
  2423   "RTN","DGO THD2",182, 0)
  2424    ;
  2425   "RTN","DGO THD2",183, 0)
  2426    ;date in  external f ormat
  2427   "RTN","DGO THD2",184, 0)
  2428   DATE(X) ; 
  2429   "RTN","DGO THD2",185, 0)
  2430    N Y S Y=" " I $G(X)? 7N.E S Y=$ E(X,4,5)_" /"_$E(X,6, 7)_"/"_$E( X,2,3)
  2431   "RTN","DGO THD2",186, 0)
  2432    Q Y
  2433   "RTN","DGO THD2",187, 0)
  2434    ;
  2435   "RTN","DGO THD2",188, 0)
  2436    ;This pro cedure is  used to pe rform a pa tient look up for an  existing p atient in  the (#33)  file.
  2437   "RTN","DGO THD2",189, 0)
  2438    ;Paramete rs: 
  2439   "RTN","DGO THD2",190, 0)
  2440    ;  None
  2441   "RTN","DGO THD2",191, 0)
  2442    ;Returns:
  2443   "RTN","DGO THD2",192, 0)
  2444    ; in DGPA T array wh ere
  2445   "RTN","DGO THD2",193, 0)
  2446    ;  DGPAT  = IEN of p atient in  PATIENT (# 33) file o n success,  -1 on fai lure
  2447   "RTN","DGO THD2",194, 0)
  2448    ;  DGPAT( 0) = zero  node of en try select ed
  2449   "RTN","DGO THD2",195, 0)
  2450    ; return  value IEN  of patient  in PATIEN T (#33) fi le on succ ess, -1 on  failure
  2451   "RTN","DGO THD2",196, 0)
  2452   SELPAT(DGP AT) ;
  2453   "RTN","DGO THD2",197, 0)
  2454    ;- int in put vars f or ^DIC ca ll
  2455   "RTN","DGO THD2",198, 0)
  2456    N DIC,DTO UT,DUPOT,X ,Y
  2457   "RTN","DGO THD2",199, 0)
  2458    S DIC="^D GOTH(33,", DIC(0)="AE MQZV"
  2459   "RTN","DGO THD2",200, 0)
  2460    ;screen o ut all tha t are not  ACTIVE
  2461   "RTN","DGO THD2",201, 0)
  2462    S DIC("S" )="I $P(^( 0),U,2)=1"
  2463   "RTN","DGO THD2",202, 0)
  2464    ;- lookup  patient
  2465   "RTN","DGO THD2",203, 0)
  2466    D ^DIC K  DIC
  2467   "RTN","DGO THD2",204, 0)
  2468    ;- result  of lookup
  2469   "RTN","DGO THD2",205, 0)
  2470    S DGPAT=Y
  2471   "RTN","DGO THD2",206, 0)
  2472    ;- if suc cess, setu p return a rray using  output va rs from ^D IC call
  2473   "RTN","DGO THD2",207, 0)
  2474    I (+DGPAT >0) D  Q + Y
  2475   "RTN","DGO THD2",208, 0)
  2476    . S DGPAT =+Y               ;pa tient ien
  2477   "RTN","DGO THD2",209, 0)
  2478    . S DGPAT (0)=$G(Y(0 ))     ;ze ro node of  patient i n (#33) fi le
  2479   "RTN","DGO THD2",210, 0)
  2480    Q -1
  2481   "RTN","DGO THD2",211, 0)
  2482    ;
  2483   "RTN","DGO THD2",212, 0)
  2484    ;/**
  2485   "RTN","DGO THD2",213, 0)
  2486    ;Creates  a new entr y (or node  for multi ple with . 01 field)
  2487   "RTN","DGO THD2",214, 0)
  2488    ;
  2489   "RTN","DGO THD2",215, 0)
  2490    ;DGFILE -  file/subf ile number
  2491   "RTN","DGO THD2",216, 0)
  2492    ;DGIEN -  ien of the  parent fi le entry i n which th e new subf ile entry  will be in serted
  2493   "RTN","DGO THD2",217, 0)
  2494    ;DGZFDA -  array wit h values f or the fie lds
  2495   "RTN","DGO THD2",218, 0)
  2496    ; format  for DGZFDA :
  2497   "RTN","DGO THD2",219, 0)
  2498    ; DGZFDA( .01)=value  for #.01  field
  2499   "RTN","DGO THD2",220, 0)
  2500    ; DGZFDA( 3)=value f or #3 fiel d
  2501   "RTN","DGO THD2",221, 0)
  2502    ;DGRECNO  -(optional ) specify  IEN if you  want spec ific value
  2503   "RTN","DGO THD2",222, 0)
  2504    ; Note: " " then the  system wi ll assign  the entry  number its elf.
  2505   "RTN","DGO THD2",223, 0)
  2506    ;DGFLGS -  FLAGS par ameter for  UPDATE^DI E
  2507   "RTN","DGO THD2",224, 0)
  2508    ;DGLCKGL  - fully sp ecified gl obal refer ence to lo ck
  2509   "RTN","DGO THD2",225, 0)
  2510    ;DGLCKTM  - time out  for LOCK,  if LOCKTI ME=0 then  the functi on will no t lock the  file 
  2511   "RTN","DGO THD2",226, 0)
  2512    ;DGNEWRE  - optional , flag = i f 1 then a llow to cr eate a new  top level  record 
  2513   "RTN","DGO THD2",227, 0)
  2514    ;  
  2515   "RTN","DGO THD2",228, 0)
  2516    ;output :
  2517   "RTN","DGO THD2",229, 0)
  2518    ; positiv e number -  record #  created
  2519   "RTN","DGO THD2",230, 0)
  2520    ; <=0 - f ailure^err or message
  2521   "RTN","DGO THD2",231, 0)
  2522    ;
  2523   "RTN","DGO THD2",232, 0)
  2524    ;Example:
  2525   "RTN","DGO THD2",233, 0)
  2526    ;top leve l:
  2527   "RTN","DGO THD2",234, 0)
  2528    ;S DGVALS (.01)="OTH D" W $$INS REC^DG5395 2(8.1,"",. DGVALS,,,, ,1)
  2529   "RTN","DGO THD2",235, 0)
  2530    ;2nd leve l:
  2531   "RTN","DGO THD2",236, 0)
  2532    ;K DGVALS  S DGVALS( .01)=1 W $ $INSREC^DG OTHD2(33.0 1,"8",.DGV ALS)
  2533   "RTN","DGO THD2",237, 0)
  2534    ;3rd leve l:
  2535   "RTN","DGO THD2",238, 0)
  2536    ;K DGVALS  S DGVALS( .01)=1 W $ $INSREC^DG OTHD2(33.1 1,"1,8",.D GVALS)
  2537   "RTN","DGO THD2",239, 0)
  2538   INSREC(DGF ILE,DGIEN, DGZFDA,DGR ECNO,DGFLG S,DGLCKGL, DGLCKTM,DG NEWRE) ;*/
  2539   "RTN","DGO THD2",240, 0)
  2540    I ('$G(DG FILE)) Q " 0^Invalid  parameter"
  2541   "RTN","DGO THD2",241, 0)
  2542    I +$G(DGN EWRE)=0 I  $G(DGRECNO )>0,'$G(DG IEN) Q "0^ Invalid pa rameter"
  2543   "RTN","DGO THD2",242, 0)
  2544    N DGSSI,D GIENS,DGER R,DGFDA,DI ERR
  2545   "RTN","DGO THD2",243, 0)
  2546    N DGLOCK  S DGLOCK=0
  2547   "RTN","DGO THD2",244, 0)
  2548    I '$G(DGR ECNO) N DG RECNO S DG RECNO=$G(D GRECNO)
  2549   "RTN","DGO THD2",245, 0)
  2550    I DGIEN'= "" S DGIEN S="+1,"_DG IEN_"," I  $L(DGRECNO )>0 S DGSS I(1)=+DGRE CNO
  2551   "RTN","DGO THD2",246, 0)
  2552    I DGIEN=" " S DGIENS ="+1," I $ L(DGRECNO) >0 S DGSSI (1)=+DGREC NO
  2553   "RTN","DGO THD2",247, 0)
  2554    M DGFDA(D GFILE,DGIE NS)=DGZFDA
  2555   "RTN","DGO THD2",248, 0)
  2556    I $L($G(D GLCKGL)) L  +@DGLCKGL :(+$G(DGLC KTM)) S DG LOCK=$T I  'DGLOCK Q  -2  ;lock  failure
  2557   "RTN","DGO THD2",249, 0)
  2558    D UPDATE^ DIE($G(DGF LGS),"DGFD A","DGSSI" ,"DGERR")
  2559   "RTN","DGO THD2",250, 0)
  2560    I DGLOCK  L -@DGLCKG L
  2561   "RTN","DGO THD2",251, 0)
  2562    I $D(DGER R) Q "-1^" _$G(DGERR( "DIERR",1, "TEXT",1), "Update Er ror")
  2563   "RTN","DGO THD2",252, 0)
  2564    Q +$G(DGS SI(1))
  2565   "RTN","DGO THD2",253, 0)
  2566    ;
  2567   "RTN","DGO THD2",254, 0)
  2568    ;2nd 90-D ay period  start date  help text
  2569   "RTN","DGO THD2",255, 0)
  2570   HELP2 ;
  2571   "RTN","DGO THD2",256, 0)
  2572    ;
  2573   "RTN","DGO THD2",257, 0)
  2574    W !!,"The  default d ate displa yed "_$S(D GPRT<0:"be low ",1:"i n the prom pt ")_"is  the end da te of the  "
  2575   "RTN","DGO THD2",258, 0)
  2576    W !,"1st  90-Day per iod + 1 da y.",!
  2577   "RTN","DGO THD2",259, 0)
  2578   HELP1 W !
  2579   "RTN","DGO THD2",260, 0)
  2580    I DGPRT<0 ,X'="?",X' ="??" W "N ot a valid  date.",!
  2581   "RTN","DGO THD2",261, 0)
  2582    W "The st art date e ntered for  the 2nd 9 0 Day peri od must fa ll within  "
  2583   "RTN","DGO THD2",262, 0)
  2584    W !,"the  specified  date range  displayed .",!
  2585   "RTN","DGO THD2",263, 0)
  2586    I DGPRT<0  D DTRANGE ^DGOTHEDT( $G(DGDTMIN ),$G(DGDTM AX)) W !
  2587   "RTN","DGO THD2",264, 0)
  2588    Q
  2589   "RTN","DGO THD2",265, 0)
  2590    ;
  2591   "RTN","DGO THD2",266, 0)
  2592   HELP3 ;dis play help  text for 1 st 90-Day  period
  2593   "RTN","DGO THD2",267, 0)
  2594    I $G(Y)<1 ,X'="?",X' ="??" W !, "  You hav e entered  an invalid  date, ple ase enter  a valid da te." Q
  2595   "RTN","DGO THD2",268, 0)
  2596    W !,"  Th e date ent ered canno t be more  than 90 da ys in the  past."
  2597   "RTN","DGO THD2",269, 0)
  2598    W !,"  A  future dat e cannot b e entered. "
  2599   "RTN","DGO THD2",270, 0)
  2600    Q
  2601   "RTN","DGO THD2",271, 0)
  2602    ;
  2603   "RTN","DGO THD2",272, 0)
  2604    ;Prompt t he user to  enter the  name of t he person 
  2605   "RTN","DGO THD2",273, 0)
  2606    ;who auth orized the  2nd 90-da y period
  2607   "RTN","DGO THD2",274, 0)
  2608   ASKAUTH(DG PROM) ;
  2609   "RTN","DGO THD2",275, 0)
  2610    ;  Input:
  2611   "RTN","DGO THD2",276, 0)
  2612    ;   DGPRO M - prompt  text
  2613   "RTN","DGO THD2",277, 0)
  2614    ;
  2615   "RTN","DGO THD2",278, 0)
  2616    ;  Output :
  2617   "RTN","DGO THD2",279, 0)
  2618    ;   Funct ion value  - Internal  value ret urned from  ^DIR
  2619   "RTN","DGO THD2",280, 0)
  2620    ;
  2621   "RTN","DGO THD2",281, 0)
  2622    N X,Y,DIR ,DIROUT,DI RUT,DTOUT, DUOUT
  2623   "RTN","DGO THD2",282, 0)
  2624    S DIR(0)= "33.11,.07 ^^^" ; K:X ="" "" X"
  2625   "RTN","DGO THD2",283, 0)
  2626    S DIR("A" )=DGPROM
  2627   "RTN","DGO THD2",284, 0)
  2628    D ^DIR
  2629   "RTN","DGO THD2",285, 0)
  2630    Q $S($D(D UOUT):-1,$ D(DTOUT):- 1,$D(DIROU T):-1,Y="  ":-1,1:$P( Y,U))
  2631   "RTN","DGO THD2",286, 0)
  2632    ;
  2633   "RTN","DGO THD2",287, 0)
  2634    ;
  2635   "RTN","DGO THD2",288, 0)
  2636   EDAUTHBY ;                                                                                                    Option nam e:  DG OTH  AUTHORIZE  2ND 90 DA YS
  2637   "RTN","DGO THD2",289, 0)
  2638    ;Edit 2nd  Authorize d period,  Authorized  by field   --      B 2S3 RED
  2639   "RTN","DGO THD2",290, 0)
  2640    N DGARR,D GSTRDT,DGI EN33,DGAUT ,DGAUTHBY, DGAUTHRZDB Y,FDB,DGOT MSG,DGNOW, DGLOOP,DG2 STRT,DGOTM SG
  2641   "RTN","DGO THD2",291, 0)
  2642    W ! D CHE CKPT Q:$G( DGIEN33)<0
  2643   "RTN","DGO THD2",292, 0)
  2644    D GETS^DI Q(33,DGIEN 33_",",".0 1;.02;.03; 1*","I","D GARR")
  2645   "RTN","DGO THD2",293, 0)
  2646    I '$D(DGA RR(33.11," 2,1,"_DGIE N33_",",.0 7,"I")) W  !!,?5,"Sor ry, this p atient has  no 2nd au thorized p eriod of c are" Q
  2647   "RTN","DGO THD2",294, 0)
  2648    S DGSTRDT =$G(DGARR( 33.11,"2,1 ,"_DGIEN33 _",",.02," I"))
  2649   "RTN","DGO THD2",295, 0)
  2650    S DGSTDT1 =$G(DGARR( 33.11,"1,1 ,"_DGIEN33 _",",.02," I")),DGSTD T2=$G(DGAR R(33.11,"2 ,1,"_DGIEN 33_",",.02 ,"I")),DGM AXDT=$$FMA DD^XLFDT(D GSTDT1,364 )
  2651   "RTN","DGO THD2",296, 0)
  2652    I DGSTDT2 '="",(DGST DT2+90)<DT  W !!,?5," Patients 2 nd authori zed period  of care h ad ended"  Q
  2653   "RTN","DGO THD2",297, 0)
  2654    ;Edit the  Authorize d by field
  2655   "RTN","DGO THD2",298, 0)
  2656    S DGAUT=$ G(DGARR(33 .11,"2,1," _DGIEN33_" ,",.07,"I" ))
  2657   "RTN","DGO THD2",299, 0)
  2658    I DGAUT=" " W !,"You  must use  'Authorize  the 2nd 9 0 days per iod' to au thorize th is period  first,",!, ?5,"it can not be add ed here" Q
  2659   "RTN","DGO THD2",300, 0)
  2660    S DIR("A" )="Authori zed By",DI R("B")=$G( DGARR(33.1 1,"2,1,"_D GIEN33_"," ,.07,"I"))
  2661   "RTN","DGO THD2",301, 0)
  2662    S DIR(0)= "FU^0:60"  D ^DIR K D IR
  2663   "RTN","DGO THD2",302, 0)
  2664    S DGAUTHR Z=Y I DGAU THRZ=-1!($ L(DGAUTHRZ )<5!($L(DG AUTHRZ)>60 )) W !,?5, "Invalid e ntry (Must  be 5-60 c haracters) , quitting " Q
  2665   "RTN","DGO THD2",303, 0)
  2666    Q:$D(DGAU THRZ)=""!( DGAUT=DGAU THRZ)   ;Q uit if no  changes or  NULL entr y
  2667   "RTN","DGO THD2",304, 0)
  2668    D NOW^%DT C S DGNOW= %
  2669   "RTN","DGO THD2",305, 0)
  2670    S FDB(33. 11,"2,1,"_ DGIEN33_", ",.05)=DUZ ,FDB(33.11 ,"2,1,"_DG IEN33_",", .06)=$P(DG NOW,"."),F DB(33.11," 2,1,"_DGIE N33_",",.0 7)=DGAUTHR Z
  2671   "RTN","DGO THD2",306, 0)
  2672    L +^DGOTH (33,DGIEN3 3):$S($G(D ILOCKTM):D ILOCKTM,1: 5) I '$T W  !,"Unable  to lock O TH CLOCK f ile, try a gain later " Q   ;Try  to lock f ile entry
  2673   "RTN","DGO THD2",307, 0)
  2674    D FILE^DI E("U","FDB ","DGOTMSG ")
  2675   "RTN","DGO THD2",308, 0)
  2676    L -^DGOTH (33,DGIEN3 3)
  2677   "RTN","DGO THD2",309, 0)
  2678    I $D(DGOT MSG) W !," -1^Problem s saving n ew authori zed by ent ry" Q  ;Er ror occurr ed
  2679   "RTN","DGO THD2",310, 0)
  2680    W !!,?5," 2nd 90 day  period of  care Auth orized by,  changed t o: ",DGAUT HRZ
  2681   "RTN","DGO THD2",311, 0)
  2682    ;Audit th e file ent ry
  2683   "RTN","DGO THD2",312, 0)
  2684    N OLDVALU E,NEWVALUE  S OLDVALU E=DGAUT,NE WVALUE=DGA UTHRZ,CLCK NO=2 D RDA UDIT(2,OLD VALUE,NEWV ALUE)
  2685   "RTN","DGO THD2",313, 0)
  2686    ;end or A udit
  2687   "RTN","DGO THD2",314, 0)
  2688    Q
  2689   "RTN","DGO THD2",315, 0)
  2690    ;
  2691   "RTN","DGO THD2",316, 0)
  2692    ;
  2693   "RTN","DGO THD2",317, 0)
  2694   EDSTDT ;                                                                                                              Op tion:  DG  OTH ADD ST ART DT 2ND  90
  2695   "RTN","DGO THD2",318, 0)
  2696    ;Edit 2nd  Authorize d start da te  --       B2S3 RED
  2697   "RTN","DGO THD2",319, 0)
  2698    N DGARR,D GSTDT,DGST DT1,DGSTDT 2,DGIEN33, DGAUT,DGAU THBY,DGAUT HRZ,FDB,DG OTMSG,DGNO W,DGLOOP,D G2STRT,DGM INDT,DGMAX DT,DGSTDT2 N
  2699   "RTN","DGO THD2",320, 0)
  2700    W ! D CHE CKPT Q:$G( DGIEN33)<0
  2701   "RTN","DGO THD2",321, 0)
  2702    D GETS^DI Q(33,DGIEN 33_",",".0 1;.02;.03; 1*","I","D GARR")
  2703   "RTN","DGO THD2",322, 0)
  2704    I '$D(DGA RR(33.11," 2,1,"_DGIE N33_",",.0 7,"I")) W  !,?5,"This  patient h as no 2nd  authorized  period of  care" Q
  2705   "RTN","DGO THD2",323, 0)
  2706    S DGAUT=$ G(DGARR(33 .11,"2,1," _DGIEN33_" ,",.07,"I" ))
  2707   "RTN","DGO THD2",324, 0)
  2708    I DGAUT=" " W !,?5," This perio d of care  has not be en authori zed,",!,?5 ,"you cann ot enter a  start dat e until it 's authori zed" Q
  2709   "RTN","DGO THD2",325, 0)
  2710    S DGSTDT1 =$G(DGARR( 33.11,"1,1 ,"_DGIEN33 _",",.02," I")),DGSTD T2=$G(DGAR R(33.11,"2 ,1,"_DGIEN 33_",",.02 ,"I")),DGM AXDT=$$FMA DD^XLFDT(D GSTDT1,364 )
  2711   "RTN","DGO THD2",326, 0)
  2712    S DGMINDT =$$FMADD^X LFDT(DGSTD T1,91)
  2713   "RTN","DGO THD2",327, 0)
  2714    I DGSTDT2 '="" W !!, ?2,"This d ate is une ditable wi th this op tion, exis ting date  is:  ",$$F MTE^XLFDT( DGSTDT2) Q
  2715   "RTN","DGO THD2",328, 0)
  2716    I DGSTDT2 '="",DGSTD T2<DT W !, ?5,"Patien ts 2nd aut horized pe riod of ca re had end ed" Q
  2717   "RTN","DGO THD2",329, 0)
  2718    N DIR,DTO UT,DIROUT, Y,X,DUOUT, DGLOOP S D GLOOP=0
  2719   "RTN","DGO THD2",330, 0)
  2720    F  D  Q:D GLOOP
  2721   "RTN","DGO THD2",331, 0)
  2722    . S DIR(0 )="DAO^::E X",DIR("A" )="  Enter  a start d ate for pe riod 2:  " ,DIR("B")= $$FMTE^XLF DT(DGMINDT )
  2723   "RTN","DGO THD2",332, 0)
  2724    . S DIR(" A",1)="    Date must  be between : "_$$FMTE ^XLFDT(DGM INDT)_" -  "_$$FMTE^X LFDT(DGMAX DT),DIR("A ",2)="" D  ^DIR
  2725   "RTN","DGO THD2",333, 0)
  2726    . I $D(DU OUT)!$D(DT OUT)!$D(DI ROUT)!(Y="  ") S DGLO OP=1 Q
  2727   "RTN","DGO THD2",334, 0)
  2728    . I Y<DGM INDT!(Y>DG MAXDT) W ! !,?20,"  N ot a valid  date" K Y  H 2 Q  ;  Don't allo w dates if  below min imum or gr eater than  maximum
  2729   "RTN","DGO THD2",335, 0)
  2730    . I $G(Y) '="" S DGL OOP=1 Q
  2731   "RTN","DGO THD2",336, 0)
  2732    Q:'($G(Y) )
  2733   "RTN","DGO THD2",337, 0)
  2734    S DGSTDT2 N=Y D NOW^ %DTC S DGN OW=%   ;Ad ded the ne w start da te, leavin g the old  start date  intact, i t should a lways be N ULL
  2735   "RTN","DGO THD2",338, 0)
  2736    S FDB(33. 11,"2,1,"_ DGIEN33_", ",.05)=DUZ ,FDB(33.11 ,"2,1,"_DG IEN33_",", .06)=$P(DG NOW,"."),F DB(33.11," 2,1,"_DGIE N33_",",.0 2)=DGSTDT2 N
  2737   "RTN","DGO THD2",339, 0)
  2738    L +^DGOTH (33,DGIEN3 3):$S($G(D ILOCKTM):D ILOCKTM,1: 5) I '$T W  !,"Unable  to lock O TH CLOCK f ile, try a gain later " Q
  2739   "RTN","DGO THD2",340, 0)
  2740    D FILE^DI E("U","FDB ","DGOTMSG ")
  2741   "RTN","DGO THD2",341, 0)
  2742    L -^DGOTH (33,DGIEN3 3)
  2743   "RTN","DGO THD2",342, 0)
  2744    I $D(DGOT MSG) W !,? 5,"-1^Prob lems savin g new auth orized by  entry" Q
  2745   "RTN","DGO THD2",343, 0)
  2746    W !!,?5," 2nd 90 day  period of  care star t date, ch anged to:  ",Y(0)
  2747   "RTN","DGO THD2",344, 0)
  2748    ;Audit en try
  2749   "RTN","DGO THD2",345, 0)
  2750    N OLDVALU E,NEWVALUE  S OLDVALU E=DGSTDT2, NEWVALUE=D GSTDT2N,CL CKNO=2 D R DAUDIT(1,O LDVALUE,NE WVALUE)
  2751   "RTN","DGO THD2",346, 0)
  2752    ;end of A udit
  2753   "RTN","DGO THD2",347, 0)
  2754    Q
  2755   "RTN","DGO THD2",348, 0)
  2756    ;
  2757   "RTN","DGO THD2",349, 0)
  2758   CHECKPT ;   Used by E DAUTHBY an d EDSTDT
  2759   "RTN","DGO THD2",350, 0)
  2760    ; Get Pt,  quit if f ound
  2761   "RTN","DGO THD2",351, 0)
  2762    N DG365,D G90,DGRES
  2763   "RTN","DGO THD2",352, 0)
  2764    S (DGIEN3 3,DGLOOP)= 0 F  D  Q: DGLOOP=1
  2765   "RTN","DGO THD2",353, 0)
  2766    . S DGIEN 33=$$SELPA T^DGOTHD2( .DGARR)
  2767   "RTN","DGO THD2",354, 0)
  2768    . I DGARR <1 S DGLOO P=1 Q
  2769   "RTN","DGO THD2",355, 0)
  2770    . I $P(DG ARR(0),U,2 )'=1!(DGIE N33<0) S D GLOOP=1 Q
  2771   "RTN","DGO THD2",356, 0)
  2772    . I $P(DG ARR(0),U,3 )=1 W !,?5 ,"VBA ADJU DICATION h as been CO MPLETED",! ,?8,"Pleas e select a nother pat ient.",! S  DGIEN33=- 1 Q
  2773   "RTN","DGO THD2",357, 0)
  2774    . S DGDFN =$$GETPAT^ DGOTHD2(DG IEN33),DGR ES=$$OTHDC LCK^DGOTHD (DGDFN,DT)
  2775   "RTN","DGO THD2",358, 0)
  2776    . I DGRES <0 W !!,"E rror"_$S($ L($P(DGRES ,U,2))>0:" : "_$P(DGR ES,U,2),1: ""),!,"Ple ase select  another p atient." Q
  2777   "RTN","DGO THD2",359, 0)
  2778    . I DGRES =0 W !!,"P atient is  not eligib le for OTH .",!,"Plea se select  another pa tient." Q
  2779   "RTN","DGO THD2",360, 0)
  2780    . S DG365 =$P(DGRES, U,1) I DG3 65>1 W !!, ?5,"Patien t has more  than one  365 days O TH periods !",!,?5,"A uthorizati on can be  entered on ly for the  last 365  days perio d." Q
  2781   "RTN","DGO THD2",361, 0)
  2782    . S DG90= $P(DGRES,U ,2) ;I DG9 0=2 W !!,? 5,"The pat ient is in  the secon d 90 day p eriod at t he moment. ",!,?5,"Pl ease selec t another  patient."  Q
  2783   "RTN","DGO THD2",362, 0)
  2784    . I DG90= 3 W !!,?5, "Patient h as used bo th periods  in this 3 65 day per iod.",!,?5 ,"Please s elect anot her patien t." Q
  2785   "RTN","DGO THD2",363, 0)
  2786    . S DGLOO P=1
  2787   "RTN","DGO THD2",364, 0)
  2788    Q
  2789   "RTN","DGO THD2",365, 0)
  2790   RDAUDIT(DG FIELD,OLDV ALUE,NEWVA LUE) ;  Us ed by EDAU THBY and E DSTDT
  2791   "RTN","DGO THD2",366, 0)
  2792    ;Audit ch anges to f ile #33 to  file #33. 1
  2793   "RTN","DGO THD2",367, 0)
  2794    N DGVALS, DGHSTIEN
  2795   "RTN","DGO THD2",368, 0)
  2796    S DGHSTIE N=+$O(^DGO TH(33.1,"B ",DGARR,0) )
  2797   "RTN","DGO THD2",369, 0)
  2798    I DGHSTIE N=0 S DGVA LS(.01)=DG IEN33 D IN SREC(33.1, "",.DGVALS ) S DGHSTI EN=+$O(^DG OTH(33.1," B",DGARR,0 ))
  2799   "RTN","DGO THD2",370, 0)
  2800    N DGVALS
  2801   "RTN","DGO THD2",371, 0)
  2802    S DGVALS( .01)=DGARR ("33.01"," 1,"_DGIEN3 3_",",".01 ","I"),DGV ALS(.02)=C LCKNO,DGVA LS(.03)=DG FIELD  ;up dated fiel d number
  2803   "RTN","DGO THD2",372, 0)
  2804    S DGVALS( .04)=OLDVA LUE,DGVALS (.05)=NEWV ALUE,DGVAL S(.06)=$S( $G(DUZ)>0: +DUZ,1:.5) ,DGVALS(.0 7)=$$NOW^X LFDT()
  2805   "RTN","DGO THD2",373, 0)
  2806    D INSREC( 33.12,DGHS TIEN,.DGVA LS)
  2807   "RTN","DGO THD2",374, 0)
  2808    Q
  2809   "RTN","DGO THEDT")
  2810   0^7^B20761 8520
  2811   "RTN","DGO THEDT",1,0 )
  2812   DGOTHEDT ; SLC/RM - O THD (OTHER  THAN HONO RABLE DISC HARGE) API s ;March 2 7,2018@16: 38
  2813   "RTN","DGO THEDT",2,0 )
  2814    ;;5.3;Reg istration; **952**;Au g 13, 1993 ;Build 68
  2815   "RTN","DGO THEDT",3,0 )
  2816    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  2817   "RTN","DGO THEDT",4,0 )
  2818    ;
  2819   "RTN","DGO THEDT",5,0 )
  2820    ;     Las t Edited:  SHRPE/RM -  May 02, 2 018 16:08
  2821   "RTN","DGO THEDT",6,0 )
  2822    ;
  2823   "RTN","DGO THEDT",7,0 )
  2824    ; ICR#  T YPE        DESCRIPTIO N
  2825   "RTN","DGO THEDT",8,0 )
  2826    ;-----  - ---        ---------- ---------- ---------- -
  2827   "RTN","DGO THEDT",9,0 )
  2828    ; 2056    Sup        GETS^DIQ
  2829   "RTN","DGO THEDT",10, 0)
  2830    ; 10103   Sup        ^XLFDT: $$ FMTE, $$NO W, $$FMADD , $$FMDIFF
  2831   "RTN","DGO THEDT",11, 0)
  2832    ; 10061   Sup        DEM^VADPT
  2833   "RTN","DGO THEDT",12, 0)
  2834    ; 10026   Sup        ^DIR
  2835   "RTN","DGO THEDT",13, 0)
  2836    ; 6873    Cont Sub   $$OTHDCLCK ^DGOTHD
  2837   "RTN","DGO THEDT",14, 0)
  2838    Q
  2839   "RTN","DGO THEDT",15, 0)
  2840    ;
  2841   "RTN","DGO THEDT",16, 0)
  2842    ;Allow us er to edit  the start  date for  1st/2nd 90 -Day perio d.
  2843   "RTN","DGO THEDT",17, 0)
  2844    ;This is   only limi ted to use rs who hav e appropri ate 
  2845   "RTN","DGO THEDT",18, 0)
  2846    ;security  access fo r menu opt ion "ESDT    Edit 90- Day Start  Date".
  2847   "RTN","DGO THEDT",19, 0)
  2848    ;Entry po int DG OTH  EDIT STAR T DATE opt ion
  2849   "RTN","DGO THEDT",20, 0)
  2850    ;B2S3
  2851   "RTN","DGO THEDT",21, 0)
  2852    ;
  2853   "RTN","DGO THEDT",22, 0)
  2854   ESTRTDT ;
  2855   "RTN","DGO THEDT",23, 0)
  2856    ;
  2857   "RTN","DGO THEDT",24, 0)
  2858    N DGLOOP
  2859   "RTN","DGO THEDT",25, 0)
  2860    S DGLOOP= 0
  2861   "RTN","DGO THEDT",26, 0)
  2862    ;keep ask ing until  empty inpu t
  2863   "RTN","DGO THEDT",27, 0)
  2864    F  D  Q:D GLOOP=1
  2865   "RTN","DGO THEDT",28, 0)
  2866    . N DGARR ,DGSTRDT,D GIEN33,DFN ,DGRES,DGL S365D,DGLS 365I,DGN,D GAUTH
  2867   "RTN","DGO THEDT",29, 0)
  2868    . N DGSTR DT,DG90A,D GLVL,DGDFV L,DGANSWR, I,DGERR
  2869   "RTN","DGO THEDT",30, 0)
  2870    . W !
  2871   "RTN","DGO THEDT",31, 0)
  2872    . S DGIEN 33=$$SELPA T^DGOTHD2( .DGARR)
  2873   "RTN","DGO THEDT",32, 0)
  2874    . I DGIEN 33<0 S DGL OOP=1 Q
  2875   "RTN","DGO THEDT",33, 0)
  2876    . S DFN=$ $GETPAT^DG OTHD2(DGIE N33)
  2877   "RTN","DGO THEDT",34, 0)
  2878    . ;
  2879   "RTN","DGO THEDT",35, 0)
  2880    . I '$$IS OTHD^DGOTH D(DFN) D   Q
  2881   "RTN","DGO THEDT",36, 0)
  2882    . . D HEA DER(DFN)
  2883   "RTN","DGO THEDT",37, 0)
  2884    . . W !!, "Patient i s not elig ible for O TH.",!
  2885   "RTN","DGO THEDT",38, 0)
  2886    . ;
  2887   "RTN","DGO THEDT",39, 0)
  2888    . D GETS^ DIQ(33,DGI EN33_","," .01;.02;.0 3;1*","I", "DGARR","D GERR")
  2889   "RTN","DGO THEDT",40, 0)
  2890    . ;
  2891   "RTN","DGO THEDT",41, 0)
  2892    . I $G(DG ARR(33,DGI EN33_",",. 02,"I"))'= 1  D  Q
  2893   "RTN","DGO THEDT",42, 0)
  2894    . . D HEA DER(DFN)
  2895   "RTN","DGO THEDT",43, 0)
  2896    . . W !!, "The patie nt's OTH c lock has b een inacti vated."
  2897   "RTN","DGO THEDT",44, 0)
  2898    . ;
  2899   "RTN","DGO THEDT",45, 0)
  2900    . I $G(DG ARR(33,DGI EN33_",",. 03,"I"))=1  D  Q
  2901   "RTN","DGO THEDT",46, 0)
  2902    . . D HEA DER(DFN)
  2903   "RTN","DGO THEDT",47, 0)
  2904    . . W !!, "VBA ADJUD ICATION ha s been COM PLETED"
  2905   "RTN","DGO THEDT",48, 0)
  2906    . ;
  2907   "RTN","DGO THEDT",49, 0)
  2908    . S DGLS3 65D=+$O(^D GOTH(33,DG IEN33,1,"B ",999),-1)
  2909   "RTN","DGO THEDT",50, 0)
  2910    . S DGLS3 65I=+$O(^D GOTH(33,DG IEN33,1,"B ",DGLS365D ,0))
  2911   "RTN","DGO THEDT",51, 0)
  2912    . S DGN=0  F  S DGN= +$O(^DGOTH (33,DGIEN3 3,1,DGLS36 5I,1,"B",D GN)) Q:DGN =0  D
  2913   "RTN","DGO THEDT",52, 0)
  2914    . . S DG9 0A(DGN)=+$ O(^DGOTH(3 3,DGIEN33, 1,DGLS365I ,1,"B",DGN ,0))
  2915   "RTN","DGO THEDT",53, 0)
  2916    . S DGSTR DT=-1
  2917   "RTN","DGO THEDT",54, 0)
  2918    . ;
  2919   "RTN","DGO THEDT",55, 0)
  2920    . ;No 365 -Day clock  started o r
  2921   "RTN","DGO THEDT",56, 0)
  2922    . ;1st 90 -Day not s tarted or  missing
  2923   "RTN","DGO THEDT",57, 0)
  2924    . I (DGLS 365D'>0)!( '$D(DG90A( 1))) D  Q
  2925   "RTN","DGO THEDT",58, 0)
  2926    . . D HEA DER(DFN)
  2927   "RTN","DGO THEDT",59, 0)
  2928    . . W !!, "The patie nts 1st 90 -Day perio d has not  started.", !!
  2929   "RTN","DGO THEDT",60, 0)
  2930    . . Q:$$S TDTYN(0,1) '=1
  2931   "RTN","DGO THEDT",61, 0)
  2932    . . W !
  2933   "RTN","DGO THEDT",62, 0)
  2934    . . D STR DATE1^DGOT HD(DFN)
  2935   "RTN","DGO THEDT",63, 0)
  2936    . . I DGL S365D'>0 S  DGLVL=1
  2937   "RTN","DGO THEDT",64, 0)
  2938    . . I '$D (DG90A(1)) ,DGLS365D> 0 S DGLVL= 2
  2939   "RTN","DGO THEDT",65, 0)
  2940    . . Q:DGS TRDT<0
  2941   "RTN","DGO THEDT",66, 0)
  2942    . . D SET CLOCK(DFN, DGSTRDT,DG IEN33,DGLV L)
  2943   "RTN","DGO THEDT",67, 0)
  2944    . ;
  2945   "RTN","DGO THEDT",68, 0)
  2946    . S DGRES =$$OTHDCLC K^DGOTHD(D FN,DT)
  2947   "RTN","DGO THEDT",69, 0)
  2948    . I DGRES <0 W !!,"E rror"_$S($ L($P(DGRES ,U,2))>0:" : "_$P(DGR ES,U,2),1: ""),!,"Ple ase select  another p atient.",!  Q
  2949   "RTN","DGO THEDT",70, 0)
  2950    . W @IOF
  2951   "RTN","DGO THEDT",71, 0)
  2952    . ;
  2953   "RTN","DGO THEDT",72, 0)
  2954    . ;Start  Date edit:  users wit h DG OTH E DIT securi ty key are  allowed 
  2955   "RTN","DGO THEDT",73, 0)
  2956    . ;to mak e changes  for the 90 -Day OTH C LOCK start  date
  2957   "RTN","DGO THEDT",74, 0)
  2958    . ;
  2959   "RTN","DGO THEDT",75, 0)
  2960    . ;First  90-day edi t only
  2961   "RTN","DGO THEDT",76, 0)
  2962    . I $D(DG 90A(1)),'$ D(DG90A(2) ) D DSPLY6 (1,DGRES,D FN,DGIEN33 ,DGLS365I, .DG90A) Q
  2963   "RTN","DGO THEDT",77, 0)
  2964    . ;1st or  2nd 90-Da y Edit
  2965   "RTN","DGO THEDT",78, 0)
  2966    . I $D(DG 90A(1)),$D (DG90A(2))  D  Q
  2967   "RTN","DGO THEDT",79, 0)
  2968    . . I $P( DGRES,U,3) '="",$P(DG RES,U,5)=0 ,$P(DGRES, U,6)'="",$ P(DGRES,U, 8)=0 D  Q   ;both per iod expire d
  2969   "RTN","DGO THEDT",80, 0)
  2970    . . . D H EADER(DFN)  W !!
  2971   "RTN","DGO THEDT",81, 0)
  2972    . . . F I =1:1:2 D
  2973   "RTN","DGO THEDT",82, 0)
  2974    . . . . I  I=2 W !!
  2975   "RTN","DGO THEDT",83, 0)
  2976    . . . . D  DSPLY4(I) ,DSPLY5(DG RES,I)
  2977   "RTN","DGO THEDT",84, 0)
  2978    . . . W ! !,"Not edi table. Bot h 1st and  2nd 90-Day  OTH clock  expired."
  2979   "RTN","DGO THEDT",85, 0)
  2980    . . I $P( DGRES,U,6) ="",$P(DGR ES,U,9)'=" " D DSPLY6 (1,DGRES,D FN,DGIEN33 ,DGLS365I, .DG90A) Q   ;period 2  has been  authorized  without s tarting da te
  2981   "RTN","DGO THEDT",86, 0)
  2982    . . I $P( DGRES,U,5) =0,$P(DGRE S,U,6)'="" ,$P(DGRES, U,8)<90 D  DSPLY7(DGR ES,DFN,DGI EN33,DGLS3 65I,.DG90A ) Q  ;peri od 1 expir ed, edit o nly the 2n d 90-Day O TH
  2983   "RTN","DGO THEDT",87, 0)
  2984    . . I $P( DGRES,U,6) '="",$P(DG RES,U,9)'= "" D DSPLY 7(DGRES,DF N,DGIEN33, DGLS365I,. DG90A) Q    ;period 1  is read-o nly, perio d 2 has be en authori zed with s tarting da te
  2985   "RTN","DGO THEDT",88, 0)
  2986    . . D DSP LY1(DFN,DG RES,.DG90A ,DGIEN33,D GLS365I) ; edit both  periods
  2987   "RTN","DGO THEDT",89, 0)
  2988    . ;
  2989   "RTN","DGO THEDT",90, 0)
  2990    . S DGLOO P=1
  2991   "RTN","DGO THEDT",91, 0)
  2992    Q
  2993   "RTN","DGO THEDT",92, 0)
  2994    ;
  2995   "RTN","DGO THEDT",93, 0)
  2996    ; Input:
  2997   "RTN","DGO THEDT",94, 0)
  2998    ;   CLCKN O - clock  #
  2999   "RTN","DGO THEDT",95, 0)
  3000    ;   DGLVL
  3001   "RTN","DGO THEDT",96, 0)
  3002    ;       1   - if the  question  comes from  the 1st 9 0-day ques tion
  3003   "RTN","DGO THEDT",97, 0)
  3004    ;       2   - if the  question  comes from  the 2nd 9 0-day ques tion
  3005   "RTN","DGO THEDT",98, 0)
  3006    ; Output:  
  3007   "RTN","DGO THEDT",99, 0)
  3008    ;   1 YES
  3009   "RTN","DGO THEDT",100 ,0)
  3010    ;   0 NO
  3011   "RTN","DGO THEDT",101 ,0)
  3012    ;   -1 if  cancelled
  3013   "RTN","DGO THEDT",102 ,0)
  3014    ;
  3015   "RTN","DGO THEDT",103 ,0)
  3016   STDTYN(CLC KNO,DGLVL)  ;
  3017   "RTN","DGO THEDT",104 ,0)
  3018    Q $$YESNO ^DGOTHD2(" Do you wan t to set t he"_$S(CLC KNO>0:" ne w ",1:" ") _"start da te for the  "_$S(DGLV L=1:"1st", 1:"2nd")_"  OTH perio d (Y/N)",, DGLVL)
  3019   "RTN","DGO THEDT",105 ,0)
  3020    ;
  3021   "RTN","DGO THEDT",106 ,0)
  3022    ; Input:
  3023   "RTN","DGO THEDT",107 ,0)
  3024    ;   DFN     - Patien t's IEN
  3025   "RTN","DGO THEDT",108 ,0)
  3026    ;   DGRES   - contai ns the OTH  90-Day pe riod data
  3027   "RTN","DGO THEDT",109 ,0)
  3028    ;           = p1^p2^ p3^p4^p5^p 6^p7^p8^p9
  3029   "RTN","DGO THEDT",110 ,0)
  3030    ;   DG90A   - pass b y referenc e
  3031   "RTN","DGO THEDT",111 ,0)
  3032    ;           - determ ine if pat ient has O TH day clo ck (1 or 2 ) started
  3033   "RTN","DGO THEDT",112 ,0)
  3034    ;   DGAUT H - Author ized BY
  3035   "RTN","DGO THEDT",113 ,0)
  3036    ;
  3037   "RTN","DGO THEDT",114 ,0)
  3038   DSPLY1(DFN ,DGRES,DG9 0A,DGAUTH, DGIEN33,DG LS365I) ;
  3039   "RTN","DGO THEDT",115 ,0)
  3040    ;
  3041   "RTN","DGO THEDT",116 ,0)
  3042    S DGANSWR =$$DSPLY2( DFN,DGRES, .DG90A,$P( DGRES,U,9) )
  3043   "RTN","DGO THEDT",117 ,0)
  3044    Q:DGANSWR <0
  3045   "RTN","DGO THEDT",118 ,0)
  3046    I DGANSWR =1 S DGDFV L=$S($P(DG RES,U,3)'= "":$$FMTE^ XLFDT($P(D GRES,U,3)) ,1:"T")
  3047   "RTN","DGO THEDT",119 ,0)
  3048    I DGANSWR =2 S DGDFV L=$$FMTE^X LFDT($P(DG RES,U,6))
  3049   "RTN","DGO THEDT",120 ,0)
  3050    ;D HELP1( DGANSWR),H ELP2(DGANS WR)
  3051   "RTN","DGO THEDT",121 ,0)
  3052    S DGSTRDT =$$ASKSTDT (DFN,DGDFV L,DGANSWR)
  3053   "RTN","DGO THEDT",122 ,0)
  3054    I DGSTRDT >0 D UPDTC LCK(DGANSW R,DGIEN33, DGLS365I,D GSTRDT,.DG 90A)
  3055   "RTN","DGO THEDT",123 ,0)
  3056    Q
  3057   "RTN","DGO THEDT",124 ,0)
  3058    ;
  3059   "RTN","DGO THEDT",125 ,0)
  3060   DSPLY2(DFN ,DGRES,DG9 0A,DGAUTH)  ;
  3061   "RTN","DGO THEDT",126 ,0)
  3062    ;
  3063   "RTN","DGO THEDT",127 ,0)
  3064    N X,Y,DIR ,DIROUT,DI RUT,DTOUT, DUOUT
  3065   "RTN","DGO THEDT",128 ,0)
  3066    ;
  3067   "RTN","DGO THEDT",129 ,0)
  3068    D HEADER( DFN)
  3069   "RTN","DGO THEDT",130 ,0)
  3070    S DIR("A" )="Select  90-Day Per iod"
  3071   "RTN","DGO THEDT",131 ,0)
  3072    S DIR("?? ")="^D EST DTHLP^DGOT HEDT(DFN,D GRES,DGAUT H)"
  3073   "RTN","DGO THEDT",132 ,0)
  3074    I $D(DG90 A(1)) D DS PLY3(1,DGR ES,DGAUTH)
  3075   "RTN","DGO THEDT",133 ,0)
  3076    I $D(DG90 A(2)),DGAU TH'="",$P( DGRES,U,6) '="" D DSP LY3(2,DGRE S,DGAUTH)
  3077   "RTN","DGO THEDT",134 ,0)
  3078    D ^DIR
  3079   "RTN","DGO THEDT",135 ,0)
  3080    Q $S($D(D UOUT):-1,$ D(DTOUT):- 1,$D(DIROU T):-1,X="" :-1,1:$P(Y ,U))
  3081   "RTN","DGO THEDT",136 ,0)
  3082    ;
  3083   "RTN","DGO THEDT",137 ,0)
  3084   DSPLY3(CLC KNO,DGRES, DGAUTH) ;
  3085   "RTN","DGO THEDT",138 ,0)
  3086    ;
  3087   "RTN","DGO THEDT",139 ,0)
  3088    W !!
  3089   "RTN","DGO THEDT",140 ,0)
  3090    I CLCKNO= 1 S DIR(0) ="SO^1:Fir st 90-Day  Start Date  Edit^"
  3091   "RTN","DGO THEDT",141 ,0)
  3092    I CLCKNO= 2 D
  3093   "RTN","DGO THEDT",142 ,0)
  3094    . I $P(DG RES,U,5)=0 ,$P(DGRES, U,6)'="",$ P(DGRES,U, 8)<90 S DI R(0)="SO^2 :Second 90 -Day Start  Date Edit ^" Q
  3095   "RTN","DGO THEDT",143 ,0)
  3096    . S DIR(0 )="SO^1:Fi rst 90-Day  Start Dat e Edit;2:S econd 90-D ay Start D ate Edit^"
  3097   "RTN","DGO THEDT",144 ,0)
  3098    S DIR(0)= DIR(0)_"K: +X'=X!(X>" _CLCKNO_")  X"
  3099   "RTN","DGO THEDT",145 ,0)
  3100    S DIR("B" )=CLCKNO
  3101   "RTN","DGO THEDT",146 ,0)
  3102    D DSPLY4( CLCKNO)
  3103   "RTN","DGO THEDT",147 ,0)
  3104    D DSPLY5( DGRES,CLCK NO)
  3105   "RTN","DGO THEDT",148 ,0)
  3106    Q
  3107   "RTN","DGO THEDT",149 ,0)
  3108    ;
  3109   "RTN","DGO THEDT",150 ,0)
  3110   DSPLY4(CLC KNO) ;
  3111   "RTN","DGO THEDT",151 ,0)
  3112    I CLCKNO= 1 W "   36 5 Day Peri od: ",DGLS 365D,!,"1s t 90-Day P eriod:"
  3113   "RTN","DGO THEDT",152 ,0)
  3114    I CLCKNO= 2 W !!,"2n d 90-Day P eriod:"
  3115   "RTN","DGO THEDT",153 ,0)
  3116    I CLCKNO= 3 W !!,"3r d 90-Day P eriod:"
  3117   "RTN","DGO THEDT",154 ,0)
  3118    I CLCKNO= 4 W !!,"4t h 90-Day P eriod:"
  3119   "RTN","DGO THEDT",155 ,0)
  3120    I CLCKNO= 5 W !!,"5t h 90-Day P eriod:"
  3121   "RTN","DGO THEDT",156 ,0)
  3122    Q
  3123   "RTN","DGO THEDT",157 ,0)
  3124    ;
  3125   "RTN","DGO THEDT",158 ,0)
  3126   DSPLY5(DGR ES,CLCKNO)  ;
  3127   "RTN","DGO THEDT",159 ,0)
  3128    N OTHSMRY ,SEQ
  3129   "RTN","DGO THEDT",160 ,0)
  3130    I CLCKNO= 1 D
  3131   "RTN","DGO THEDT",161 ,0)
  3132    . S OTHSM RY(CLCKNO, 1)=$S($P(D GRES,U,3)= "":"< None  Specified  >",1:$$FM TE^XLFDT($ P(DGRES,U, 1))) ;star t date
  3133   "RTN","DGO THEDT",162 ,0)
  3134    . S OTHSM RY(CLCKNO, 2)=$S($P(D GRES,U,3)= "":"< None  Specified  >",1:$$FM TE^XLFDT($ P(DGRES,U, 2))) ;end  date
  3135   "RTN","DGO THEDT",163 ,0)
  3136    . S OTHSM RY(CLCKNO, 3)=$S($P(D GRES,U,3)= "":" ",1:$ $FMTE^XLFD T($P(DGRES ,U,3))) ;d ays remain ing
  3137   "RTN","DGO THEDT",164 ,0)
  3138    ;
  3139   "RTN","DGO THEDT",165 ,0)
  3140    I CLCKNO= 2,$P(DGRES ,U,4)'=""  D
  3141   "RTN","DGO THEDT",166 ,0)
  3142    . S OTHSM RY(CLCKNO, 1)=$S($P(D GRES,U,6)= "":"< None  Specified  >",1:$$FM TE^XLFDT($ P(DGRES,U, 4))) ;star t date
  3143   "RTN","DGO THEDT",167 ,0)
  3144    . S OTHSM RY(CLCKNO, 2)=$S($P(D GRES,U,6)= "":"< None  Specified  >",1:$$FM TE^XLFDT($ P(DGRES,U, 5))) ;end  date
  3145   "RTN","DGO THEDT",168 ,0)
  3146    . S OTHSM RY(CLCKNO, 3)=$S($P(D GRES,U,6)= "":" ",1:$ $FMTE^XLFD T($P(DGRES ,U,6))) ;d ays remain ing
  3147   "RTN","DGO THEDT",169 ,0)
  3148    ;
  3149   "RTN","DGO THEDT",170 ,0)
  3150    I CLCKNO= 3,$P(DGRES ,U,7)'=""  D
  3151   "RTN","DGO THEDT",171 ,0)
  3152    . S OTHSM RY(CLCKNO, 1)=$S($P(D GRES,U,6)= "":"< None  Specified  >",1:$$FM TE^XLFDT($ P(DGRES,U, 7))) ;star t date
  3153   "RTN","DGO THEDT",172 ,0)
  3154    . S OTHSM RY(CLCKNO, 2)=$S($P(D GRES,U,6)= "":"< None  Specified  >",1:$$FM TE^XLFDT($ P(DGRES,U, 8))) ;end  date
  3155   "RTN","DGO THEDT",173 ,0)
  3156    . S OTHSM RY(CLCKNO, 3)=$S($P(D GRES,U,6)= "":" ",1:$ $FMTE^XLFD T($P(DGRES ,U,9))) ;d ays remain ing
  3157   "RTN","DGO THEDT",174 ,0)
  3158    ;
  3159   "RTN","DGO THEDT",175 ,0)
  3160    I CLCKNO= 4,$P(DGRES ,U,10)'=""  D
  3161   "RTN","DGO THEDT",176 ,0)
  3162    . S OTHSM RY(CLCKNO, 1)=$S($P(D GRES,U,6)= "":"< None  Specified  >",1:$$FM TE^XLFDT($ P(DGRES,U, 10))) ;sta rt date
  3163   "RTN","DGO THEDT",177 ,0)
  3164    . S OTHSM RY(CLCKNO, 2)=$S($P(D GRES,U,6)= "":"< None  Specified  >",1:$$FM TE^XLFDT($ P(DGRES,U, 11))) ;end  date
  3165   "RTN","DGO THEDT",178 ,0)
  3166    . S OTHSM RY(CLCKNO, 3)=$S($P(D GRES,U,6)= "":" ",1:$ $FMTE^XLFD T($P(DGRES ,U,12))) ; days remai ning
  3167   "RTN","DGO THEDT",179 ,0)
  3168    ;
  3169   "RTN","DGO THEDT",180 ,0)
  3170    I CLCKNO= 5,$P(DGRES ,U,13)'=""  D
  3171   "RTN","DGO THEDT",181 ,0)
  3172    . S OTHSM RY(CLCKNO, 1)=$S($P(D GRES,U,6)= "":"< None  Specified  >",1:$$FM TE^XLFDT($ P(DGRES,U, 13))) ;sta rt date
  3173   "RTN","DGO THEDT",182 ,0)
  3174    . S OTHSM RY(CLCKNO, 2)=$S($P(D GRES,U,6)= "":"< None  Specified  >",1:$$FM TE^XLFDT($ P(DGRES,U, 14))) ;end  date
  3175   "RTN","DGO THEDT",183 ,0)
  3176    . S OTHSM RY(CLCKNO, 3)=$S($P(D GRES,U,6)= "":" ",1:$ $FMTE^XLFD T($P(DGRES ,U,15))) ; days remai ning
  3177   "RTN","DGO THEDT",184 ,0)
  3178    ;
  3179   "RTN","DGO THEDT",185 ,0)
  3180    S SEQ=""  F  S SEQ=$ O(OTHSMRY( CLCKNO,SEQ )) Q:SEQ=" "  D
  3181   "RTN","DGO THEDT",186 ,0)
  3182    . I SEQ=1  W !,"Star t Date: ", OTHSMRY(CL CKNO,SEQ)
  3183   "RTN","DGO THEDT",187 ,0)
  3184    . I SEQ=2  W ?30,"En d Date: ", OTHSMRY(CL CKNO,SEQ)
  3185   "RTN","DGO THEDT",188 ,0)
  3186    . I SEQ=3  W ?60,"Da ys Remaini ng: ",$S($ P(^DGOTH(3 3,DGIEN33, 0),"^",6)= "":OTHSMRY (CLCKNO,SE Q),1:"0")
  3187   "RTN","DGO THEDT",189 ,0)
  3188    . Q
  3189   "RTN","DGO THEDT",190 ,0)
  3190    . I CLCKN O=1,SEQ=3  D
  3191   "RTN","DGO THEDT",191 ,0)
  3192    . . I $P( DGRES,U,5) =0,$P(DGRE S,U,6)'="" ,$P(DGRES, U,8)>0,$P( DGRES,U,8) <90 D  Q
  3193   "RTN","DGO THEDT",192 ,0)
  3194    . . . W ! !,"        NOTE:  1st  90-Day Pe riod is un editable."
  3195   "RTN","DGO THEDT",193 ,0)
  3196    . . . W ! ,"               2nd  90-Day OTH  clock has  been auth orized."
  3197   "RTN","DGO THEDT",194 ,0)
  3198    . . I $P( DGRES,U,6) '="",$P(DG RES,U,8)'= 0,$P(DGRES ,U,9)'=""  D
  3199   "RTN","DGO THEDT",195 ,0)
  3200    . . . W ! !,"      N OTE:   1st  90-Day Pe riod is re ad-only"
  3201   "RTN","DGO THEDT",196 ,0)
  3202    . . . W ! ,"               2nd  90-Day Per iod has be en authori zed"
  3203   "RTN","DGO THEDT",197 ,0)
  3204    K OTHSMRY
  3205   "RTN","DGO THEDT",198 ,0)
  3206    Q
  3207   "RTN","DGO THEDT",199 ,0)
  3208    ;
  3209   "RTN","DGO THEDT",200 ,0)
  3210   DSPLY6(CLC KNO,DGRES, DFN,DGIEN3 3,DGLS365I ,DG90A) ;
  3211   "RTN","DGO THEDT",201 ,0)
  3212    ;
  3213   "RTN","DGO THEDT",202 ,0)
  3214    S DGDFVL= $S($P(DGRE S,U,3)'="" :$$FMTE^XL FDT($P(DGR ES,U,3)),1 :"T")
  3215   "RTN","DGO THEDT",203 ,0)
  3216    D HEADER( DFN)
  3217   "RTN","DGO THEDT",204 ,0)
  3218    W !!
  3219   "RTN","DGO THEDT",205 ,0)
  3220    D DSPLY4( CLCKNO),DS PLY5(DGRES ,CLCKNO)
  3221   "RTN","DGO THEDT",206 ,0)
  3222    W !
  3223   "RTN","DGO THEDT",207 ,0)
  3224    ;D HELP1( CLCKNO),HE LP2(CLCKNO )
  3225   "RTN","DGO THEDT",208 ,0)
  3226    I CLCKNO= 1,$P(DGRES ,U,3)>0,$P (DGRES,U,5 )=0 D  Q:$ $STDTYN(1, 1)'=1
  3227   "RTN","DGO THEDT",209 ,0)
  3228    . W !!,"W ARNING:"," '",$P(DGRE S,U,5),"'" ," Days Re maining fo r 1st 90-D ay Period" ,!
  3229   "RTN","DGO THEDT",210 ,0)
  3230    S DGSTRDT =$$ASKSTDT (DFN,DGDFV L,CLCKNO)
  3231   "RTN","DGO THEDT",211 ,0)
  3232    I DGSTRDT >0 D UPDTC LCK(CLCKNO ,DGIEN33,D GLS365I,DG STRDT,.DG9 0A)
  3233   "RTN","DGO THEDT",212 ,0)
  3234    Q
  3235   "RTN","DGO THEDT",213 ,0)
  3236    ;
  3237   "RTN","DGO THEDT",214 ,0)
  3238   DSPLY7(DGR ES,DFN,DGI EN33,DGLS3 65I,DG90A)  ;
  3239   "RTN","DGO THEDT",215 ,0)
  3240    ;
  3241   "RTN","DGO THEDT",216 ,0)
  3242    D HEADER( DFN) W !!
  3243   "RTN","DGO THEDT",217 ,0)
  3244    F I=1:1:2  D
  3245   "RTN","DGO THEDT",218 ,0)
  3246    . I I=2 W  !!
  3247   "RTN","DGO THEDT",219 ,0)
  3248    . D DSPLY 4(I),DSPLY 5(DGRES,I)
  3249   "RTN","DGO THEDT",220 ,0)
  3250    ;D HELP1( 2),HELP2(I )
  3251   "RTN","DGO THEDT",221 ,0)
  3252    S DGDFVL= $$FMTE^XLF DT($P(DGRE S,U,6))
  3253   "RTN","DGO THEDT",222 ,0)
  3254    S DGSTRDT =$$ASKSTDT (DFN,DGDFV L,2)
  3255   "RTN","DGO THEDT",223 ,0)
  3256    I DGSTRDT >0 D UPDTC LCK(2,DGIE N33,DGLS36 5I,DGSTRDT ,.DG90A)
  3257   "RTN","DGO THEDT",224 ,0)
  3258    Q
  3259   "RTN","DGO THEDT",225 ,0)
  3260    ;
  3261   "RTN","DGO THEDT",226 ,0)
  3262   ESTDTHLP(D FN,DGRES,D GAUTH) ;
  3263   "RTN","DGO THEDT",227 ,0)
  3264    ;
  3265   "RTN","DGO THEDT",228 ,0)
  3266    N I
  3267   "RTN","DGO THEDT",229 ,0)
  3268    W !!
  3269   "RTN","DGO THEDT",230 ,0)
  3270    D HEADER( DFN)
  3271   "RTN","DGO THEDT",231 ,0)
  3272    W !!
  3273   "RTN","DGO THEDT",232 ,0)
  3274    I $D(DG90 A(1)),'$D( DG90A(2))  D
  3275   "RTN","DGO THEDT",233 ,0)
  3276    . D DSPLY 4(1),DSPLY 5(DGRES,1)
  3277   "RTN","DGO THEDT",234 ,0)
  3278    . I DGAUT H="",$P(DG RES,U,6)=" ",$P(DGRES ,U,5)=0 D  AUTHMSG(1)
  3279   "RTN","DGO THEDT",235 ,0)
  3280    . I DGAUT H'="",$P(D GRES,U,6)= "" D DSPLY 4(2),AUTHM SG(2)
  3281   "RTN","DGO THEDT",236 ,0)
  3282    ;
  3283   "RTN","DGO THEDT",237 ,0)
  3284    I $D(DG90 A(1)),$D(D G90A(2)) D
  3285   "RTN","DGO THEDT",238 ,0)
  3286    . F I=1:1 :2 D
  3287   "RTN","DGO THEDT",239 ,0)
  3288    . . I I=2  W !!
  3289   "RTN","DGO THEDT",240 ,0)
  3290    . . D DSP LY4(I)
  3291   "RTN","DGO THEDT",241 ,0)
  3292    . . I DGA UTH="",$P( DGRES,U,6) ="" D DSPL Y4(2),AUTH MSG(1)
  3293   "RTN","DGO THEDT",242 ,0)
  3294    . . I DGA UTH'="",$P (DGRES,U,6 )="" D DSP LY4(2),AUT HMSG(2)
  3295   "RTN","DGO THEDT",243 ,0)
  3296    . . E  D  DSPLY5(DGR ES,I)
  3297   "RTN","DGO THEDT",244 ,0)
  3298    Q
  3299   "RTN","DGO THEDT",245 ,0)
  3300    ;
  3301   "RTN","DGO THEDT",246 ,0)
  3302   HELP1(CLCK NO) ;
  3303   "RTN","DGO THEDT",247 ,0)
  3304    ;
  3305   "RTN","DGO THEDT",248 ,0)
  3306    N I
  3307   "RTN","DGO THEDT",249 ,0)
  3308    I CLCKNO= 1 D
  3309   "RTN","DGO THEDT",250 ,0)
  3310    . W !!,"P eriod 1 st art date s hould be l ess than t he Period  1 end date "
  3311   "RTN","DGO THEDT",251 ,0)
  3312    . W !,"Pe riod 1 end  date shou ld be less  than the  2 Period s tart date"
  3313   "RTN","DGO THEDT",252 ,0)
  3314    . W !,"Pe riod 1 edi t allowed  only if Pe riod 2 has  not start ed"
  3315   "RTN","DGO THEDT",253 ,0)
  3316    . W !,"Pe riod 1 is  read-only  if period  2 is autho rized with  a start d ate"
  3317   "RTN","DGO THEDT",254 ,0)
  3318    ;
  3319   "RTN","DGO THEDT",255 ,0)
  3320    I CLCKNO= 2 D
  3321   "RTN","DGO THEDT",256 ,0)
  3322    . W !!,"P eriod 2 st art date s hould be l ess than t he Period  2 end date "
  3323   "RTN","DGO THEDT",257 ,0)
  3324    . W !,"Au thorizatio n required  to enter  a start da te for per iod 2"
  3325   "RTN","DGO THEDT",258 ,0)
  3326    I CLCKNO= "" F I=1:1 :2 D HELP1 (I) I I=2  D HELP2(CL CKNO)
  3327   "RTN","DGO THEDT",259 ,0)
  3328    Q
  3329   "RTN","DGO THEDT",260 ,0)
  3330    ;
  3331   "RTN","DGO THEDT",261 ,0)
  3332   HELP2(CLCK NO) ;
  3333   "RTN","DGO THEDT",262 ,0)
  3334    ;
  3335   "RTN","DGO THEDT",263 ,0)
  3336    W !!,"OTH  90-Day Pe riod of ca re cannot  overlap",!
  3337   "RTN","DGO THEDT",264 ,0)
  3338    W !,"No e dits allow ed if both  periods 1  and 2 hav e zero day s remainin g"
  3339   "RTN","DGO THEDT",265 ,0)
  3340    W !,"No e dit allowe d if the d ate is inv alid - Exa mple June  31st"
  3341   "RTN","DGO THEDT",266 ,0)
  3342    I CLCKNO= 2 D
  3343   "RTN","DGO THEDT",267 ,0)
  3344    . W !!,"T he start d ate entere d for the  2nd 90-Day  period mu st fall"
  3345   "RTN","DGO THEDT",268 ,0)
  3346    . W !,"wi thin the e arliest an d latest d ate range  specified. ",!
  3347   "RTN","DGO THEDT",269 ,0)
  3348    Q
  3349   "RTN","DGO THEDT",270 ,0)
  3350    ;
  3351   "RTN","DGO THEDT",271 ,0)
  3352   AUTHMSG(MS GNO) ;
  3353   "RTN","DGO THEDT",272 ,0)
  3354    ;
  3355   "RTN","DGO THEDT",273 ,0)
  3356    I MSGNO=1  D
  3357   "RTN","DGO THEDT",274 ,0)
  3358    . W !,"        Autho rization R equired."
  3359   "RTN","DGO THEDT",275 ,0)
  3360    . W !,"        Patie nt is NOT  eligible f or care at  this time ."
  3361   "RTN","DGO THEDT",276 ,0)
  3362    . W !,"        If yo u wish to  authorized  the 2nd 9 0-Day peri od,"
  3363   "RTN","DGO THEDT",277 ,0)
  3364    . W !,"        Go to  option AU TH   Autho rize the 2 nd 90 days  period."
  3365   "RTN","DGO THEDT",278 ,0)
  3366    ;
  3367   "RTN","DGO THEDT",279 ,0)
  3368    I MSGNO=2  D
  3369   "RTN","DGO THEDT",280 ,0)
  3370    . W !!,"        This  selection  is not ed itable."
  3371   "RTN","DGO THEDT",281 ,0)
  3372    . W !,"         The  2nd 90-Day  OTH perio d has been  authorize d without  a starting  date."
  3373   "RTN","DGO THEDT",282 ,0)
  3374    . W !,"         Go t o option A ST2   Add  start date  2nd 90 da ys"
  3375   "RTN","DGO THEDT",283 ,0)
  3376    Q
  3377   "RTN","DGO THEDT",284 ,0)
  3378    ;
  3379   "RTN","DGO THEDT",285 ,0)
  3380   HEADER(DFN ) ;
  3381   "RTN","DGO THEDT",286 ,0)
  3382    ;
  3383   "RTN","DGO THEDT",287 ,0)
  3384    N DDASH,D GNAME,DGDO B,VADM
  3385   "RTN","DGO THEDT",288 ,0)
  3386    D DEM^VAD PT ;get pa tient demo graphics
  3387   "RTN","DGO THEDT",289 ,0)
  3388    S DGNAME= VADM(1),DG DOB=$P(VAD M(3),U,2)
  3389   "RTN","DGO THEDT",290 ,0)
  3390    W ?19,"OT HER THAN H ONORABLE 9 0-DAY PERI OD EDIT"
  3391   "RTN","DGO THEDT",291 ,0)
  3392    W !,"Pati ent Name:  ",DGNAME,? 60,"DOB: " ,DGDOB
  3393   "RTN","DGO THEDT",292 ,0)
  3394    S $P(DDAS H,"=",81)= "" W !,DDA SH ;write  dash lines
  3395   "RTN","DGO THEDT",293 ,0)
  3396    W !!,"OTH ER THAN HO NORABLE ST ATUS:"
  3397   "RTN","DGO THEDT",294 ,0)
  3398    Q
  3399   "RTN","DGO THEDT",295 ,0)
  3400    ;
  3401   "RTN","DGO THEDT",296 ,0)
  3402   SETCLOCK(D FN,DGSTRDT ,DGIEN33,C LCKNO) ;
  3403   "RTN","DGO THEDT",297 ,0)
  3404    ;
  3405   "RTN","DGO THEDT",298 ,0)
  3406    N DGIEN90 ,DGIEN365
  3407   "RTN","DGO THEDT",299 ,0)
  3408    ;create 3 65-day clo ck
  3409   "RTN","DGO THEDT",300 ,0)
  3410    I CLCKNO= 1 D  I DGI EN365<0 Q  DGIEN365
  3411   "RTN","DGO THEDT",301 ,0)
  3412    . S DGIEN 365=$$CR36 5CLK^DGOTH D2(+DGIEN3 3,1,DGSTRD T)
  3413   "RTN","DGO THEDT",302 ,0)
  3414    I CLCKNO= 2 S DGIEN3 65=1 ;365  days subfi le has bee n created
  3415   "RTN","DGO THEDT",303 ,0)
  3416    ;create 9 0-day cloc k
  3417   "RTN","DGO THEDT",304 ,0)
  3418    S DGIEN90 =$$CR90CLK ^DGOTHD2(+ DGIEN33,+D GIEN365,1, DGSTRDT)
  3419   "RTN","DGO THEDT",305 ,0)
  3420    ;if error  then retu rn error
  3421   "RTN","DGO THEDT",306 ,0)
  3422    I DGIEN90 <0 Q DGIEN 90
  3423   "RTN","DGO THEDT",307 ,0)
  3424    Q 1
  3425   "RTN","DGO THEDT",308 ,0)
  3426    ;
  3427   "RTN","DGO THEDT",309 ,0)
  3428   UPDTCLCK(C LCKNO,DGIE N33,DGLS36 5I,DGSTRDT ,DG90A) ;
  3429   "RTN","DGO THEDT",310 ,0)
  3430    ;
  3431   "RTN","DGO THEDT",311 ,0)
  3432    N FILENO, DGFDART,DG IENS,DGOTH ERR,DGOTH3 31,DGHSTIE N,DGFLG
  3433   "RTN","DGO THEDT",312 ,0)
  3434    S DGFLG=0
  3435   "RTN","DGO THEDT",313 ,0)
  3436    I DGSTRDT >0 D
  3437   "RTN","DGO THEDT",314 ,0)
  3438    . I CLCKN O=1,DGSTRD T=$P(DGRES ,U,3) S DG FLG=1
  3439   "RTN","DGO THEDT",315 ,0)
  3440    . I CLCKN O=2,DGSTRD T=$P(DGRES ,U,6) S DG FLG=1
  3441   "RTN","DGO THEDT",316 ,0)
  3442    Q:DGFLG>0
  3443   "RTN","DGO THEDT",317 ,0)
  3444    S FILENO= 33.11
  3445   "RTN","DGO THEDT",318 ,0)
  3446    S DGOTH33 1=-1
  3447   "RTN","DGO THEDT",319 ,0)
  3448    S DGIENS= DG90A(CLCK NO)_","_+D GLS365I_", "_+DGIEN33 _","
  3449   "RTN","DGO THEDT",320 ,0)
  3450    S DGFDART ($J,FILENO ,DGIENS,.0 1)=CLCKNO
  3451   "RTN","DGO THEDT",321 ,0)
  3452    S DGFDART ($J,FILENO ,DGIENS,.0 2)=DGSTRDT
  3453   "RTN","DGO THEDT",322 ,0)
  3454    I CLCKNO= 2 D
  3455   "RTN","DGO THEDT",323 ,0)
  3456    . S DGFDA RT($J,FILE NO,DGIENS, .03)=$S($G (DUZ)>0:+D UZ,1:.5)
  3457   "RTN","DGO THEDT",324 ,0)
  3458    . S DGFDA RT($J,FILE NO,DGIENS, .04)=$$NOW ^XLFDT()
  3459   "RTN","DGO THEDT",325 ,0)
  3460    S DGFDART ($J,FILENO ,DGIENS,.0 5)=$S($G(D UZ)>0:+DUZ ,1:.5)
  3461   "RTN","DGO THEDT",326 ,0)
  3462    S DGFDART ($J,FILENO ,DGIENS,.0 6)=$$NOW^X LFDT()
  3463   "RTN","DGO THEDT",327 ,0)
  3464    D FILE^DI E("U","DGF DART($J)", "DGOTHERR" )
  3465   "RTN","DGO THEDT",328 ,0)
  3466    I $D(DGOT HERR) W !! ,"An error  occurred  during fil ing the ne w start da te." Q
  3467   "RTN","DGO THEDT",329 ,0)
  3468    W !!,CLCK NO,$S(CLCK NO=1:"st", 1:"nd"),"  90-Day OTH  period st art date c hanged to:  ",$$FMTE^ XLFDT(DGST RDT),!!
  3469   "RTN","DGO THEDT",330 ,0)
  3470    ;create n ew/update  OTH patien t history  record
  3471   "RTN","DGO THEDT",331 ,0)
  3472    S DGOTH33 1=$G(^DGOT H(33.1,0))
  3473   "RTN","DGO THEDT",332 ,0)
  3474    Q:DGOTH33 1=""
  3475   "RTN","DGO THEDT",333 ,0)
  3476    S DGHSTIE N=+$O(^DGO TH(33.1,"B ",DGARR,0) )
  3477   "RTN","DGO THEDT",334 ,0)
  3478    D INSNWRE C(DGHSTIEN ,DGARR,CLC KNO,DGRES, DGSTRDT,+D GLS365I)
  3479   "RTN","DGO THEDT",335 ,0)
  3480    Q
  3481   "RTN","DGO THEDT",336 ,0)
  3482    ;
  3483   "RTN","DGO THEDT",337 ,0)
  3484   INSNWREC(D GHSTIEN,DG ARR,CLCKNO ,DGRES,DGS TRDT,DGLS3 65I) ;
  3485   "RTN","DGO THEDT",338 ,0)
  3486    N DGVALS
  3487   "RTN","DGO THEDT",339 ,0)
  3488    ;create n ew OTH his tory recor d
  3489   "RTN","DGO THEDT",340 ,0)
  3490    I DGHSTIE N=0 D
  3491   "RTN","DGO THEDT",341 ,0)
  3492    . S DGVAL S(.01)=DGA RR
  3493   "RTN","DGO THEDT",342 ,0)
  3494    . D INSRE C^DGOTHD2( 33.1,"",.D GVALS)
  3495   "RTN","DGO THEDT",343 ,0)
  3496    . S DGHST IEN=+$O(^D GOTH(33.1, "B",DGARR, 0))
  3497   "RTN","DGO THEDT",344 ,0)
  3498    N DGVALS
  3499   "RTN","DGO THEDT",345 ,0)
  3500    S DGVALS( .01)=DGLS3 65I
  3501   "RTN","DGO THEDT",346 ,0)
  3502    S DGVALS( .02)=CLCKN O
  3503   "RTN","DGO THEDT",347 ,0)
  3504    S DGVALS( .03)=1 ;'1 ' FOR STAR T DATE
  3505   "RTN","DGO THEDT",348 ,0)
  3506    I CLCKNO= 1 S DGVALS (.04)=$P(D GRES,U,3)
  3507   "RTN","DGO THEDT",349 ,0)
  3508    I CLCKNO= 2 S DGVALS (.04)=$P(D GRES,U,6)
  3509   "RTN","DGO THEDT",350 ,0)
  3510    Q:DGVALS( .04)=DGSTR DT
  3511   "RTN","DGO THEDT",351 ,0)
  3512    S DGVALS( .05)=DGSTR DT
  3513   "RTN","DGO THEDT",352 ,0)
  3514    S DGVALS( .06)=$S($G (DUZ)>0:+D UZ,1:.5)
  3515   "RTN","DGO THEDT",353 ,0)
  3516    S DGVALS( .07)=$$NOW ^XLFDT()
  3517   "RTN","DGO THEDT",354 ,0)
  3518    D INSREC^ DGOTHD2(33 .12,DGHSTI EN,.DGVALS )
  3519   "RTN","DGO THEDT",355 ,0)
  3520    Q
  3521   "RTN","DGO THEDT",356 ,0)
  3522    ;
  3523   "RTN","DGO THEDT",357 ,0)
  3524   ASKSTDT(DG DFN,DGDFVL ,DGCLCKNO)  ;
  3525   "RTN","DGO THEDT",358 ,0)
  3526    ;
  3527   "RTN","DGO THEDT",359 ,0)
  3528    N DGLOOP2 ,DGDTMIN,D GDTMAX,DGS TDT,DGDIR0 ,DGPRT
  3529   "RTN","DGO THEDT",360 ,0)
  3530    S DGLOOP2 =0,(DGSTDT ,DGPRT)=-1
  3531   "RTN","DGO THEDT",361 ,0)
  3532    S (DGDTMI N,DGDTMAX) =""
  3533   "RTN","DGO THEDT",362 ,0)
  3534    S DGDIR0= "DO^::EX"
  3535   "RTN","DGO THEDT",363 ,0)
  3536    I DGCLCKN O=2  D
  3537   "RTN","DGO THEDT",364 ,0)
  3538    . S DGDTM IN=$$FMADD ^XLFDT($P( DGRES,U,4) ,1)
  3539   "RTN","DGO THEDT",365 ,0)
  3540    . S DGDTM AX=$$GETST DT^DGOTHD( DGDTMIN,DG RES)
  3541   "RTN","DGO THEDT",366 ,0)
  3542    . I DGDFV L="" S DGD FVL=$$FMTE ^XLFDT(DGD TMIN)
  3543   "RTN","DGO THEDT",367 ,0)
  3544    . W !! D  DTRANGE(DG DTMIN,DGDT MAX)
  3545   "RTN","DGO THEDT",368 ,0)
  3546    ;
  3547   "RTN","DGO THEDT",369 ,0)
  3548    W !
  3549   "RTN","DGO THEDT",370 ,0)
  3550    F  D  Q:D GLOOP2=1
  3551   "RTN","DGO THEDT",371 ,0)
  3552    . S DGSTD T=$$ASKDT^ DGOTHD2("E nter new s tart date  for "_$S(D GCLCKNO=1: "1st",1:"2 nd")_" 90- Day OTH pe riod",DGDF VL,DGDIR0, DGCLCKNO)
  3553   "RTN","DGO THEDT",372 ,0)
  3554    . I DGSTD T="@" W !! ,"Could no t delete s tart date. ",!,"Delet ing the st art date w ill inacti vate the 9 0-Day OTH  clock.",!  Q
  3555   "RTN","DGO THEDT",373 ,0)
  3556    . I DGSTD T'>0 S DGL OOP2=1 Q
  3557   "RTN","DGO THEDT",374 ,0)
  3558    . I DGCLC KNO=1 D
  3559   "RTN","DGO THEDT",375 ,0)
  3560    . . I $P( DGRES,U,3) '="",$P(DG RES,U,6)'= "",$$FMADD ^XLFDT(DGS TDT,365)>D GDTMAX D   Q
  3561   "RTN","DGO THEDT",376 ,0)
  3562    . . . W ! !,"Not a v alid date. ",!,"In or der to use  the start  date you  entered,"
  3563   "RTN","DGO THEDT",377 ,0)
  3564    . . . W ! ,"you must  first edi t the 2nd  90-Day sta rt date.", !!,"The da te you ent ered overl ap the 2nd  90-Day Pe riod"
  3565   "RTN","DGO THEDT",378 ,0)
  3566    . . . W ! ,"This is  not allowe d.",!!
  3567   "RTN","DGO THEDT",379 ,0)
  3568    . . ;
  3569   "RTN","DGO THEDT",380 ,0)
  3570    . . I $$F MDIFF^XLFD T(DT,DGSTD T)>90 W !! ,"Not a va lid date." ,!,"The da te you ent ered canno t be more  than 90 da ys in the  past.",! Q
  3571   "RTN","DGO THEDT",381 ,0)
  3572    . . ;
  3573   "RTN","DGO THEDT",382 ,0)
  3574    . . I DGS TDT>DT W ! !,"Not a v alid date.  A future  date canno t be enter ed.",! Q
  3575   "RTN","DGO THEDT",383 ,0)
  3576    . . S DGL OOP2=1
  3577   "RTN","DGO THEDT",384 ,0)
  3578    . ;
  3579   "RTN","DGO THEDT",385 ,0)
  3580    . I DGCLC KNO=2 D
  3581   "RTN","DGO THEDT",386 ,0)
  3582    . . I DGS TDT<=$P(DG RES,U,4) D   Q
  3583   "RTN","DGO THEDT",387 ,0)
  3584    . . . W ! !,"Not a v alid date. ",!,"The d ate you en tered fall s within t he 1st 90- Day Period .",!,"This  is not al lowed.",!
  3585   "RTN","DGO THEDT",388 ,0)
  3586    . . . D D TRANGE(DGD TMIN,DGDTM AX) W !
  3587   "RTN","DGO THEDT",389 ,0)
  3588    . . I DGS TDT>DGDTMA X W ! D HE LP1^DGOTHD 2 Q
  3589   "RTN","DGO THEDT",390 ,0)
  3590    . . S DGL OOP2=1
  3591   "RTN","DGO THEDT",391 ,0)
  3592    Q DGSTDT
  3593   "RTN","DGO THEDT",392 ,0)
  3594    ;
  3595   "RTN","DGO THEDT",393 ,0)
  3596   DTRANGE(DG DTMIN,DGDT MAX) ;
  3597   "RTN","DGO THEDT",394 ,0)
  3598    W !,"Date  Range: ", $$FMTE^XLF DT(DGDTMIN )," - ",$$ FMTE^XLFDT (DGDTMAX)
  3599   "RTN","DGO THEDT",395 ,0)
  3600    Q
  3601   "RTN","DGO THEDT",396 ,0)
  3602    ;
  3603   "RTN","DGO THINQ")
  3604   0^14^B2237 9584
  3605   "RTN","DGO THINQ",1,0 )
  3606   DGOTHINQ ; SLC/RM - O THD (OTHER  THAN HONO RABLE DISC HARGE) API s ;August  03,2018@13 :16
  3607   "RTN","DGO THINQ",2,0 )
  3608    ;;5.3;Reg istration; **952**;Au g 13, 1993 ;Build 68
  3609   "RTN","DGO THINQ",3,0 )
  3610    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  3611   "RTN","DGO THINQ",4,0 )
  3612    ;
  3613   "RTN","DGO THINQ",5,0 )
  3614    ;     Las t Edited:  SHRPE/RM -  August 03 ,2018 13:1 6
  3615   "RTN","DGO THINQ",6,0 )
  3616    ;
  3617   "RTN","DGO THINQ",7,0 )
  3618    ; ICR#  T YPE        DESCRIPTIO N
  3619   "RTN","DGO THINQ",8,0 )
  3620    ;-----  - ---        ---------- ---------- ---------- -
  3621   "RTN","DGO THINQ",9,0 )
  3622    ; 2056    Sup        GETS^DIQ,G ET1^DIQ
  3623   "RTN","DGO THINQ",10, 0)
  3624    ; 10103   Sup        ^XLFDT: $$ FMTE, $$NO W, $$FMADD , $$FMDIFF
  3625   "RTN","DGO THINQ",11, 0)
  3626    ; 10061   Sup        DEM^VADPT
  3627   "RTN","DGO THINQ",12, 0)
  3628    ; 10026   Sup        ^DIR
  3629   "RTN","DGO THINQ",13, 0)
  3630    ; 6873    Cont Sub   $$OTHDCLCK ^DGOTHD
  3631   "RTN","DGO THINQ",14, 0)
  3632    Q
  3633   "RTN","DGO THINQ",15, 0)
  3634    ;
  3635   "RTN","DGO THINQ",16, 0)
  3636    ;This opt ion will d isplay the  Other Tha n Honorabl e
  3637   "RTN","DGO THINQ",17, 0)
  3638    ;Patient  count down  clock dem ographics
  3639   "RTN","DGO THINQ",18, 0)
  3640    ;Entry po int DG OTH  PATIENT I NQ option
  3641   "RTN","DGO THINQ",19, 0)
  3642    ;B4S1
  3643   "RTN","DGO THINQ",20, 0)
  3644    ;
  3645   "RTN","DGO THINQ",21, 0)
  3646   EN ;
  3647   "RTN","DGO THINQ",22, 0)
  3648    N DGLOOP
  3649   "RTN","DGO THINQ",23, 0)
  3650    S DGLOOP= 0
  3651   "RTN","DGO THINQ",24, 0)
  3652    ;
  3653   "RTN","DGO THINQ",25, 0)
  3654    F  D  Q:D GLOOP=1
  3655   "RTN","DGO THINQ",26, 0)
  3656    . N DGIEN 33,DFN,DGA RR,DG90A,D GPTST,DGPT NM,DGFLG,D GSTAT,DGRE S
  3657   "RTN","DGO THINQ",27, 0)
  3658    . N DGLS3 65D,DGLS36 5I
  3659   "RTN","DGO THINQ",28, 0)
  3660    . S (DGFL G,DGSTAT)= 0
  3661   "RTN","DGO THINQ",29, 0)
  3662    . W !
  3663   "RTN","DGO THINQ",30, 0)
  3664    . S DGPTN M=$$SELPAT ^DGOTHRI(. DGARR),DGI EN33=DGARR
  3665   "RTN","DGO THINQ",31, 0)
  3666    . I DGIEN 33<0 S DGL OOP=1 Q
  3667   "RTN","DGO THINQ",32, 0)
  3668    . S DFN=$ $GETPAT^DG OTHD2(DGIE N33)
  3669   "RTN","DGO THINQ",33, 0)
  3670    . W @IOF
  3671   "RTN","DGO THINQ",34, 0)
  3672    . ;D GETS ^DIQ(33,DG IEN33_",", ".01;.02;. 03;.06;.07 ;.08;.09;1 *","EI","D GARR","DGE RR")
  3673   "RTN","DGO THINQ",35, 0)
  3674    . D GETS^ DIQ(33,DGI EN33_","," .01;.02;.0 6;1*","EI" ,"DGARR"," DGERR")
  3675   "RTN","DGO THINQ",36, 0)
  3676    . S DGSTA T=$$STATUS ^DGOTHRI(. DGARR)
  3677   "RTN","DGO THINQ",37, 0)
  3678    . I '$$IS OTHD^DGOTH D(DFN) D   Q
  3679   "RTN","DGO THINQ",38, 0)
  3680    . . D HEA DER(DFN,DG STAT)
  3681   "RTN","DGO THINQ",39, 0)
  3682    . . W !!, "Patient i s not elig ible for O TH.",!
  3683   "RTN","DGO THINQ",40, 0)
  3684    . D CLOCK ^DGOTHRP2( DGIEN33)
  3685   "RTN","DGO THINQ",41, 0)
  3686    . I ('$D( DG90A))!(' $D(DG90A(1 ))) D  Q
  3687   "RTN","DGO THINQ",42, 0)
  3688    . . D HEA DER(DFN,DG STAT)
  3689   "RTN","DGO THINQ",43, 0)
  3690    . . W !!, "The patie nt's 1st 9 0-Day peri od has not  started." ,!
  3691   "RTN","DGO THINQ",44, 0)
  3692    . . W !," Please go  to 'Edit 9 0-Day Star t Date' op tion,",!," if you wis h to start  the 1st 9 0-Day peri od.",!!
  3693   "RTN","DGO THINQ",45, 0)
  3694    . S DGRES =$$RESULT^ DGOTHRP3(. DGARR,.DG9 0A,DGIEN33 )
  3695   "RTN","DGO THINQ",46, 0)
  3696    . I DGRES <0 D  Q
  3697   "RTN","DGO THINQ",47, 0)
  3698    . . W !!, "Error"_$S ($L($P(DGR ES,U,2))>0 :": "_$P(D GRES,U,2), 1:""),!,"P lease sele ct another  patient." ,!
  3699   "RTN","DGO THINQ",48, 0)
  3700    . I $D(DG 90A(1)),'$ D(DG90A(2) ) D  Q
  3701   "RTN","DGO THINQ",49, 0)
  3702    . . D HEA DER(DFN,DG STAT) W !!
  3703   "RTN","DGO THINQ",50, 0)
  3704    . . D DSP LY4^DGOTHE DT(1),DSPL Y5^DGOTHED T(DGRES,1)
  3705   "RTN","DGO THINQ",51, 0)
  3706    . . I 23[ DGSTAT D M SG(DGSTAT, .DGARR,DGI EN33) Q
  3707   "RTN","DGO THINQ",52, 0)
  3708    . . I $P( DGRES,U,3) <1 D
  3709   "RTN","DGO THINQ",53, 0)
  3710    . . . W ! !,"     >>  1st 90-Da y Period o f care has  been auth orized wit hout a sta rting date .",!
  3711   "RTN","DGO THINQ",54, 0)
  3712    . I $D(DG 90A(1)),$D (DG90A(2))  D
  3713   "RTN","DGO THINQ",55, 0)
  3714    . . ;I $P (DGRES,U,3 )'="",$P(D GRES,U,5)= 0,$P(DGRES ,U,6)'="", $P(DGRES,U ,8)=0 D  Q   ;both pe riod expir ed
  3715   "RTN","DGO THINQ",56, 0)
  3716    . . I $P( DGRES,U,$L (DGRES,U)) =0 D  Q  ; last perio d expired
  3717   "RTN","DGO THINQ",57, 0)
  3718    . . . D H EADER(DFN, DGSTAT) W  !!
  3719   "RTN","DGO THINQ",58, 0)
  3720    . . . D P RNTD(DGRES )
  3721   "RTN","DGO THINQ",59, 0)
  3722    . . . S D GFLG=1
  3723   "RTN","DGO THINQ",60, 0)
  3724    . . . I 2 3[DGSTAT D  MSG(DGSTA T,.DGARR,D GIEN33) Q
  3725   "RTN","DGO THINQ",61, 0)
  3726    . . . ;W  !!,"Not ed itable. Bo th 1st and  2nd 90-Da y OTH cloc k expired. "
  3727   "RTN","DGO THINQ",62, 0)
  3728    . . . W ! !,"Not edi table. the  last 90-D ay OTH clo ck expired ."
  3729   "RTN","DGO THINQ",63, 0)
  3730    . . I $P( DGRES,U,6) ="",$P(DGR ES,U,9)'=" " D  Q
  3731   "RTN","DGO THINQ",64, 0)
  3732    . . . D H EADER(DFN, DGSTAT) W  !!
  3733   "RTN","DGO THINQ",65, 0)
  3734    . . . D P RNTD(DGRES )
  3735   "RTN","DGO THINQ",66, 0)
  3736    . . . S D GFLG=1
  3737   "RTN","DGO THINQ",67, 0)
  3738    . . . I 2 3[DGSTAT D  MSG(DGSTA T,.DGARR,D GIEN33) Q
  3739   "RTN","DGO THINQ",68, 0)
  3740    . . . I $ P(DGRES,U, 9)'="" D 
  3741   "RTN","DGO THINQ",69, 0)
  3742    . . . . W  !! D DSPL Y4^DGOTHED T(2),DSPLY 5^DGOTHEDT (DGRES,2)
  3743   "RTN","DGO THINQ",70, 0)
  3744    . . . . W  !!,"    > > 2nd 90-D ay Period  of care ha s been aut horized wi thout a st arting dat e.",!
  3745   "RTN","DGO THINQ",71, 0)
  3746    . . . . W  !,"        Please go  to 'Add s tart date  2nd 90 day s' option" ,!,"        if you wi sh to add  the 2nd 90 -Day perio d start da te.",!
  3747   "RTN","DGO THINQ",72, 0)
  3748    . Q:DGFLG
  3749   "RTN","DGO THINQ",73, 0)
  3750    . D HEADE R(DFN,DGST AT) W !!
  3751   "RTN","DGO THINQ",74, 0)
  3752    . D PRNTD (DGRES)
  3753   "RTN","DGO THINQ",75, 0)
  3754    . I 23[DG STAT D MSG (DGSTAT,.D GARR,DGIEN 33)
  3755   "RTN","DGO THINQ",76, 0)
  3756    Q
  3757   "RTN","DGO THINQ",77, 0)
  3758    ;
  3759   "RTN","DGO THINQ",78, 0)
  3760   PRNTD(DGRE S) ;print  OTH patien t count do wn clock d emographic s
  3761   "RTN","DGO THINQ",79, 0)
  3762    N I,DGCLC K
  3763   "RTN","DGO THINQ",80, 0)
  3764    S DGCLCK= +$O(DG90A( 9),-1)
  3765   "RTN","DGO THINQ",81, 0)
  3766    F I=1:1:D GCLCK D
  3767   "RTN","DGO THINQ",82, 0)
  3768    . D DSPLY 4^DGOTHEDT (I),DSPLY5 ^DGOTHEDT( DGRES,I)
  3769   "RTN","DGO THINQ",83, 0)
  3770    Q
  3771   "RTN","DGO THINQ",84, 0)
  3772    ;
  3773   "RTN","DGO THINQ",85, 0)
  3774   MSG(DGSTAT ,DGARR,DGI EN33) ;dis play inact ivation/ad judication  message
  3775   "RTN","DGO THINQ",86, 0)
  3776    N DGRSN,D GLSDT,DGRS NIN
  3777   "RTN","DGO THINQ",87, 0)
  3778    W !
  3779   "RTN","DGO THINQ",88, 0)
  3780    ;S DGRSN= DGARR(33,D GIEN33_"," ,.09,"E")   ;  (no lo nger avail able)
  3781   "RTN","DGO THINQ",89, 0)
  3782    S DGLSDT= $O(^DGOTH( 33,3,2,"B" ,"A"),-1), DGRSNIN=$O (^DGOTH(33 ,3,2,"B",D GLSDT,999) ,-1)
  3783   "RTN","DGO THINQ",90, 0)
  3784    S DGRSN=$ $GET1^DIQ( 33.02,DGRS NIN_","_DG IEN33_",", ".04")
  3785   "RTN","DGO THINQ",91, 0)
  3786    I DGRSN=" " S DGRSN= "Not Provi ded"
  3787   "RTN","DGO THINQ",92, 0)
  3788    I 2[DGSTA T W !,"  A djudicatio n Date: ", $$FMTE^XLF DT(DGARR(3 3,DGIEN33_ ",",.06,"I "))
  3789   "RTN","DGO THINQ",93, 0)
  3790    I 3[DGSTA T W !,"       *** INA CTIVE ***    "  ;,$$F MTE^XLFDT( DGARR(33,D GIEN33_"," ,.08,"I"))  (We nolon ger have t his data f ield)
  3791   "RTN","DGO THINQ",94, 0)
  3792    W ?45,"Re ason: ",DG RSN  ;$E(D GRSN,1,55) ,!,?21,$E( DGRSN,56,$ L(DGRSN))
  3793   "RTN","DGO THINQ",95, 0)
  3794    Q
  3795   "RTN","DGO THINQ",96, 0)
  3796    ;
  3797   "RTN","DGO THINQ",97, 0)
  3798   HEADER(DFN ,DGSTAT) ;
  3799   "RTN","DGO THINQ",98, 0)
  3800    ;
  3801   "RTN","DGO THINQ",99, 0)
  3802    N DDASH,D GNAME,DGDO B,VADM,DGS SN
  3803   "RTN","DGO THINQ",100 ,0)
  3804    D DEM^VAD PT ;get pa tient demo graphics
  3805   "RTN","DGO THINQ",101 ,0)
  3806    S DGNAME= VADM(1),DG DOB=$P(VAD M(3),U,2), DGSSN=$P($ P(VADM(2), U,2),"-",3 )
  3807   "RTN","DGO THINQ",102 ,0)
  3808    W ?19,"OT HER THAN H ONORABLE P ATIENT INQ UIRY"
  3809   "RTN","DGO THINQ",103 ,0)
  3810    W !,"Pati ent Name:  ",DGNAME,? 45,"DOB: " ,DGDOB,?68 ,"PID: ",D GSSN
  3811   "RTN","DGO THINQ",104 ,0)
  3812    S $P(DDAS H,"=",81)= "" W !,DDA SH ;write  dash lines
  3813   "RTN","DGO THINQ",105 ,0)
  3814    I ('$D(DG 90A))!('$D (DG90A(1)) ) Q
  3815   "RTN","DGO THINQ",106 ,0)
  3816    W "OTHER  THAN HONOR ABLE STATU S: **",$S( DGSTAT=1:"  ACTIVE/NO T ADJUDICA TED",DGSTA T=2:" ADJU DICATED",D GSTAT=3:"  INACTIVE", 1:"")," ** "
  3817   "RTN","DGO THINQ",107 ,0)
  3818    Q
  3819   "RTN","DGO THINQ",108 ,0)
  3820    ;
  3821   "RTN","DGO THRI")
  3822   0^12^B2372 68923
  3823   "RTN","DGO THRI",1,0)
  3824   DGOTHRI ;S LC/RM - OT HD (OTHER  THAN HONOR ABLE DISCH ARGE) APIs  ;April 27 ,2018@21:0 8
  3825   "RTN","DGO THRI",2,0)
  3826    ;;5.3;Reg istration; **952**;Au g 13, 1993 ;Build 68
  3827   "RTN","DGO THRI",3,0)
  3828    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  3829   "RTN","DGO THRI",4,0)
  3830    ;
  3831   "RTN","DGO THRI",5,0)
  3832    ;     Las t Edited:  SHRPE/RM -  July 05,  2018 15:50
  3833   "RTN","DGO THRI",6,0)
  3834    ;
  3835   "RTN","DGO THRI",7,0)
  3836    ; ICR#  T YPE  DESCR IPTION
  3837   "RTN","DGO THRI",8,0)
  3838    ;-----  - ---  ----- ---------- ---------- ------
  3839   "RTN","DGO THRI",9,0)
  3840    ; 10006   Sup  ^DIC
  3841   "RTN","DGO THRI",10,0 )
  3842    ; 10103   Sup  ^XLFD T:$$FMTE,  $$NOW
  3843   "RTN","DGO THRI",11,0 )
  3844    ; 10026   Sup  ^DIR
  3845   "RTN","DGO THRI",12,0 )
  3846    ; 10015   Sup  GETS^ DIQ
  3847   "RTN","DGO THRI",13,0 )
  3848    ; 10061   Sup  ^VADP T: 4 , KVA R, KVA
  3849   "RTN","DGO THRI",14,0 )
  3850    ; 2053    Sup  ^DIE: FILE, UPDA TE
  3851   "RTN","DGO THRI",15,0 )
  3852    Q
  3853   "RTN","DGO THRI",16,0 )
  3854    ;
  3855   "RTN","DGO THRI",17,0 )
  3856   EN ;entry  for DG OTH  STOP/REAC TIVATE CLO CK patient  count dow n clock
  3857   "RTN","DGO THRI",18,0 )
  3858    ;
  3859   "RTN","DGO THRI",19,0 )
  3860    N DGFIRST  ;first OT H patient  DFN
  3861   "RTN","DGO THRI",20,0 )
  3862    N DGERR    ;error me ssage arra y
  3863   "RTN","DGO THRI",21,0 )
  3864    N DGARR    ;array fo r file 33  data
  3865   "RTN","DGO THRI",22,0 )
  3866    N DGSORT   ;array or  report pa rameters
  3867   "RTN","DGO THRI",23,0 )
  3868    N DGSEL    ;help tex t var
  3869   "RTN","DGO THRI",24,0 )
  3870    N DGLIST   ;temp glo bal name u sed for OT H-90 repor t
  3871   "RTN","DGO THRI",25,0 )
  3872    N DGLOOP
  3873   "RTN","DGO THRI",26,0 )
  3874    N DGLN
  3875   "RTN","DGO THRI",27,0 )
  3876    ;
  3877   "RTN","DGO THRI",28,0 )
  3878    ;check fo r EMERGENT  OTH KEY
  3879   "RTN","DGO THRI",29,0 )
  3880    I '$D(^XU SEC("DG OT H EDIT",DU Z)) D  Q
  3881   "RTN","DGO THRI",30,0 )
  3882    . W !?2," >>> Emerge nt OTH Key  is requir ed for you  to INACTI VATE or RE ACTIVATE t he clock." ,*7
  3883   "RTN","DGO THRI",31,0 )
  3884    . I $$ANS WER^DGOTHR PT("Enter  RETURN to  continue", "","E")
  3885   "RTN","DGO THRI",32,0 )
  3886    ;
  3887   "RTN","DGO THRI",33,0 )
  3888    ;check fo r database
  3889   "RTN","DGO THRI",34,0 )
  3890    S DGFIRST =$P(+$O(^D GOTH(33,"B ","")),"," ) ;first O TH DFN
  3891   "RTN","DGO THRI",35,0 )
  3892    I 'DGFIRS T D  Q
  3893   "RTN","DGO THRI",36,0 )
  3894    . W !?2," >>> No 'Ot her Than H onorable'  Patient Re cord have  been found .",*7
  3895   "RTN","DGO THRI",37,0 )
  3896    . I $$ANS WER^DGOTHR PT("Enter  RETURN to  continue", "","E")
  3897   "RTN","DGO THRI",38,0 )
  3898    W @IOF
  3899   "RTN","DGO THRI",39,0 )
  3900    D HDR1
  3901   "RTN","DGO THRI",40,0 )
  3902    S DGLOOP= 0
  3903   "RTN","DGO THRI",41,0 )
  3904    S DGLIST= $NA(^TMP(" OTH90",$J) )
  3905   "RTN","DGO THRI",42,0 )
  3906    K @DGLIST
  3907   "RTN","DGO THRI",43,0 )
  3908    ;keep ask ing until  empty inpu t
  3909   "RTN","DGO THRI",44,0 )
  3910    F  D  Q:D GLOOP=1
  3911   "RTN","DGO THRI",45,0 )
  3912    . N DGIEN 33,DFN,DGA RR,DGPTNM, DGADJYN,DG LOOP2,DGLS 365D,DGERR ,DGASK,DGP TST
  3913   "RTN","DGO THRI",46,0 )
  3914    . N DGLS3 65I,DGRAIN ,DGADJDT,D GRES,DGCLC K,DGDFN,DG OTHPT,DGVB A,DG90A,DG RET
  3915   "RTN","DGO THRI",47,0 )
  3916    . S DGLN= 1
  3917   "RTN","DGO THRI",48,0 )
  3918    . W !
  3919   "RTN","DGO THRI",49,0 )
  3920    . S (DGAD JYN,DGADJD T,DGRAIN,D GPTST,DGOT HPT,DGVBA, DGLS365D,D GLS365I)=0
  3921   "RTN","DGO THRI",50,0 )
  3922    . S DGPTN M=$$SELPAT (.DGARR),D GIEN33=DGA RR
  3923   "RTN","DGO THRI",51,0 )
  3924    . I DGIEN 33<0 S DGL OOP=1 Q
  3925   "RTN","DGO THRI",52,0 )
  3926    . D CLOCK ^DGOTHRP2( DGIEN33)
  3927   "RTN","DGO THRI",53,0 )
  3928    . I ('$D( DG90A))!(' $D(DG90A(1 ))) D  Q
  3929   "RTN","DGO THRI",54,0 )
  3930    . . W !!, "  The pat ients 1st  90-Day per iod has no t started. ",!!
  3931   "RTN","DGO THRI",55,0 )
  3932    . ;check  the curren t status o f the OTH  patient
  3933   "RTN","DGO THRI",56,0 )
  3934    . I DGLS3 65D'>0 D   Q
  3935   "RTN","DGO THRI",57,0 )
  3936    . . W !!, "  No 365  days clock  started f or the sel ected pati ent"
  3937   "RTN","DGO THRI",58,0 )
  3938    . . W !!, "  Please  select ano ther patie nt."
  3939   "RTN","DGO THRI",59,0 )
  3940    . S DGDFN =+DGARR(0)
  3941   "RTN","DGO THRI",60,0 )
  3942    . D GETS^ DIQ(33,DGI EN33_","," .01;.02;.0 3;.04;.05; .06;1*","E I","DGARR" ,"DGERR")
  3943   "RTN","DGO THRI",61,0 )
  3944    . ;get th e OTH cloc k for the  patient
  3945   "RTN","DGO THRI",62,0 )
  3946    . D RESUL T^DGOTHRP3 (.DGARR,.D G90A,DGIEN 33)
  3947   "RTN","DGO THRI",63,0 )
  3948    . S DGPTS T=$$STATUS (.DGARR) ; OTH patien t clock st atus
  3949   "RTN","DGO THRI",64,0 )
  3950    . ;displa y patient  demographi cs
  3951   "RTN","DGO THRI",65,0 )
  3952    . S DGOTH PT=$$DEMOG (DGDFN,.DG RET,.DGARR ,DGPTST)
  3953   "RTN","DGO THRI",66,0 )
  3954    . I DGOTH PT<1 K @DG LIST Q
  3955   "RTN","DGO THRI",67,0 )
  3956    . ; RE-AC TIVATE OTH  Patient
  3957   "RTN","DGO THRI",68,0 )
  3958    . S DGRSN ="Not Prov ided"
  3959   "RTN","DGO THRI",69,0 )
  3960    . I 23[DG PTST D  K  @DGLIST Q
  3961   "RTN","DGO THRI",70,0 )
  3962    . . W !
  3963   "RTN","DGO THRI",71,0 )
  3964    . . S DGA SK="Do you "_$S(DGPTS T=2:" stil l ",1:" ") _"want to  RE-ACTIVAT E this pat ient (Y/N) "
  3965   "RTN","DGO THRI",72,0 )
  3966    . . S DGR AIN=$$ANSW ER^DGOTHRP T(DGASK,"" ,"YO","^D  HELP^DGOTH RI(4)")
  3967   "RTN","DGO THRI",73,0 )
  3968    . . I $G( DGRAIN)<1  W !!,"<No  action tak en.>" Q
  3969   "RTN","DGO THRI",74,0 )
  3970    . . I DGR AIN>0 D
  3971   "RTN","DGO THRI",75,0 )
  3972    . . . S D GLOOP2=0
  3973   "RTN","DGO THRI",76,0 )
  3974    . . . F   D  Q:DGLOO P2=1
  3975   "RTN","DGO THRI",77,0 )
  3976    . . . . W  ! S DGRSN =$$ASKRSN( 1)
  3977   "RTN","DGO THRI",78,0 )
  3978    . . . . I  DGRSN=-1  S DGLOOP2= 1 Q
  3979   "RTN","DGO THRI",79,0 )
  3980    . . . . S  DGLOOP2=1
  3981   "RTN","DGO THRI",80,0 )
  3982    . . . I D GRSN=-1 W  !!,"  Reac tivation f ailed: Rea ctivation  reason mis sing.",!!, "<No actio n taken.>"  Q
  3983   "RTN","DGO THRI",81,0 )
  3984    . . . D S TRE(DGIEN3 3,DGADJDT, .DGARR,DGL S365I,DGCL CK,1,DGRSN ,"",DGPTST ) ;1 to re activate,  otherwise  0
  3985   "RTN","DGO THRI",82,0 )
  3986    . . . W ! !!,"  The  Other Than  Honorable  countdown  clock for  patient " ,DGPTNM,!, "  has bee n "_$S(DGP TST=2:"RES TORED",1:" RE-ACTIVAT ED")_".",!
  3987   "RTN","DGO THRI",83,0 )
  3988    . ; 
  3989   "RTN","DGO THRI",84,0 )
  3990    . ;VBA AD JUDICATION  STATUS
  3991   "RTN","DGO THRI",85,0 )
  3992    . I DGPTS T=1 D
  3993   "RTN","DGO THRI",86,0 )
  3994    . . W !
  3995   "RTN","DGO THRI",87,0 )
  3996    . . S DGA DJYN=$$ANS WER^DGOTHR PT("Did yo u receive  Adjudicati on Status  notice for  this pati ent (Y/N)" ,"","YO"," ^D HELP^DG OTHRI(2)")
  3997   "RTN","DGO THRI",88,0 )
  3998    . . I DGA DJYN>0 D
  3999   "RTN","DGO THRI",89,0 )
  4000    . . . ;pr ompt the s ource of t he VBA adj udication  informatio n
  4001   "RTN","DGO THRI",90,0 )
  4002    . . . ;1  - VBA Adju dication l etter/emai l received  by Regist ration sta ff
  4003   "RTN","DGO THRI",91,0 )
  4004    . . . ;2  - VBA lett er receive d by the P atient
  4005   "RTN","DGO THRI",92,0 )
  4006    . . . ;3  - Other
  4007   "RTN","DGO THRI",93,0 )
  4008    . . . S D GVBA=$$VBA SRCE
  4009   "RTN","DGO THRI",94,0 )
  4010    . . . I D GVBA<1 W ! !,"<No act ion taken. >" Q 
  4011   "RTN","DGO THRI",95,0 )
  4012    . . . I D GVBA>0 D
  4013   "RTN","DGO THRI",96,0 )
  4014    . . . . S  DGVBA=$P( DGSORT("DG VBAS"),U)
  4015   "RTN","DGO THRI",97,0 )
  4016    . . . . W  !
  4017   "RTN","DGO THRI",98,0 )
  4018    . . . . I  12[DGVBA  S DGRSN=$$ ASKRSN(2)
  4019   "RTN","DGO THRI",99,0 )
  4020    . . . . E   S DGRSN= $$ASKRSN(3 )
  4021   "RTN","DGO THRI",100, 0)
  4022    . . . . I  DGRSN=-1  W !!,"<No  action tak en.>" Q
  4023   "RTN","DGO THRI",101, 0)
  4024    . . . . I  (DGRSN="  "!(DGRSN=" ")),DGVBA> 0 S DGRSN= $P(DGSORT( "DGVBAS"), U,2)
  4025   "RTN","DGO THRI",102, 0)
  4026    . . . . S  DGLOOP2=0
  4027   "RTN","DGO THRI",103, 0)
  4028    . . . . F   D  Q:DGL OOP2=1
  4029   "RTN","DGO THRI",104, 0)
  4030    . . . . .  W !
  4031   "RTN","DGO THRI",105, 0)
  4032    . . . . .  S DGADJDT =$$ANSWER^ DGOTHRPT(" Enter Adju dication D ate for th is patient ","T","D^: :EX","^D H ELP^DGOTHR I(3)")
  4033   "RTN","DGO THRI",106, 0)
  4034    . . . . .  I DGADJDT <0 S DGLOO P2=1 W !!, "  <No act ion taken. >" Q
  4035   "RTN","DGO THRI",107, 0)
  4036    . . . . .  I DGADJDT >DT W !!,"   A future  date cann ot be ente red.",! Q
  4037   "RTN","DGO THRI",108, 0)
  4038    . . . . .  ; adjudic ation date  should no t go beyon d the OTH  Patient st art date
  4039   "RTN","DGO THRI",109, 0)
  4040    . . . . .  I DGADJDT <$P(DGRES, U,3) W ! S  X="" D HE LP^DGOTHRI (3) Q
  4041   "RTN","DGO THRI",110, 0)
  4042    . . . . .  I DGADJDT >0 D
  4043   "RTN","DGO THRI",111, 0)
  4044    . . . . .  . D STRE( DGIEN33,DG ADJDT,.DGA RR,DGLS365 I,DGCLCK,0 ,DGRSN,DGV BA,DGPTST)
  4045   "RTN","DGO THRI",112, 0)
  4046    . . . . .  . S DGLN= DGLN+1,@DG LIST@(DGLN ,0)=" "
  4047   "RTN","DGO THRI",113, 0)
  4048    . . . . .  . S DGLN= DGLN+1,@DG LIST@(DGLN ,0)="  Adj udication  complete f or patient  "_DGPTNM
  4049   "RTN","DGO THRI",114, 0)
  4050    . . . . .  . W !! D  WRITE
  4051   "RTN","DGO THRI",115, 0)
  4052    . . . . .  . S DGLN= DGLN+1,@DG LIST@(DGLN ,0)=" "
  4053   "RTN","DGO THRI",116, 0)
  4054    . . . . .  . S DGLN= DGLN+1,@DG LIST@(DGLN ,0)="  The  Other Tha n Honorabl e countdow n clock ha s been INA CTIVATED."
  4055   "RTN","DGO THRI",117, 0)
  4056    . . . . .  . W ! D W RITE
  4057   "RTN","DGO THRI",118, 0)
  4058    . . . . .  . S DGLN= DGLN+1,@DG LIST@(DGLN ,0)=" "
  4059   "RTN","DGO THRI",119, 0)
  4060    . . . . .  . W ! D I NACTMS2,SN DMAIL
  4061   "RTN","DGO THRI",120, 0)
  4062    . . . . .  . S DGLN= DGLN+1,@DG LIST@(DGLN ,0)=" "
  4063   "RTN","DGO THRI",121, 0)
  4064    . . . . .  S DGLOOP2 =1
  4065   "RTN","DGO THRI",122, 0)
  4066    . . . . .  W !
  4067   "RTN","DGO THRI",123, 0)
  4068    . ;
  4069   "RTN","DGO THRI",124, 0)
  4070    . I DGADJ YN=-1!(DGA DJYN="") K  @DGLIST Q
  4071   "RTN","DGO THRI",125, 0)
  4072    . ; INACT IVATE OTH  Patient
  4073   "RTN","DGO THRI",126, 0)
  4074    . I 'DGAD JYN,'DGADJ DT D  ;use r did not  received a ny Adjudic ation stat us notice  for the pa tient
  4075   "RTN","DGO THRI",127, 0)
  4076    . . W !
  4077   "RTN","DGO THRI",128, 0)
  4078    . . S DGR AIN=$$ANSW ER^DGOTHRP T("Do you  want to IN ACTIVATE t his patien t (Y/N)"," ","YO","^D  HELP^DGOT HRI(4)")
  4079   "RTN","DGO THRI",129, 0)
  4080    . . I DGR AIN>0 D
  4081   "RTN","DGO THRI",130, 0)
  4082    . . . W !  S DGRSN=$ $ANSWER^DG OTHRPT("Pl ease provi de reason  for INACTI VATION (Op tional)"," ","FO^1:60 ","^D HELP ^DGOTHRI(5 )")
  4083   "RTN","DGO THRI",131, 0)
  4084    . . . Q:D GRSN=-1
  4085   "RTN","DGO THRI",132, 0)
  4086    . . . I D GRSN<1,DGV BA>0 S DGR SN=$P(DGSO RT("DGVBAS "),U,2)
  4087   "RTN","DGO THRI",133, 0)
  4088    . . . D S TRE(DGIEN3 3,DGADJDT, .DGARR,DGL S365I,DGCL CK,0,DGRSN ,DGVBA,DGP TST) ;0 to  inactivat e
  4089   "RTN","DGO THRI",134, 0)
  4090    . . . W !  D INACTMS 1(DGPTNM)  W ".",!! D  INACTMS2
  4091   "RTN","DGO THRI",135, 0)
  4092    . . . ;se nd a copy  of the pat ient to th e user reg arding the  inactivat ion via em ail
  4093   "RTN","DGO THRI",136, 0)
  4094    . . . D S NDMAIL
  4095   "RTN","DGO THRI",137, 0)
  4096    . K @DGLI ST
  4097   "RTN","DGO THRI",138, 0)
  4098    Q
  4099   "RTN","DGO THRI",139, 0)
  4100    ;
  4101   "RTN","DGO THRI",140, 0)
  4102   VBASRCE()  ;prompt th e source o f the VBA  adjudicati on informa tion
  4103   "RTN","DGO THRI",141, 0)
  4104    ;
  4105   "RTN","DGO THRI",142, 0)
  4106    N DGASK,D GDIRA,DGDI RB,DGDIRH, DGDIRO,DGF YQ
  4107   "RTN","DGO THRI",143, 0)
  4108    S DGDIRA= "Select th e source o f the VBA  Adjudicati on"
  4109   "RTN","DGO THRI",144, 0)
  4110    S DGDIRB= ""
  4111   "RTN","DGO THRI",145, 0)
  4112    S DGDIRH= "Enter the  source of  the VBA A djudicatio n"
  4113   "RTN","DGO THRI",146, 0)
  4114    S DGDIRO= "SO^1:VBA  Adjudicati on letter/ email rece ived by Re gistration  staff;2:V BA Adjudic ation lett er receive d by the p atient;3:O ther"
  4115   "RTN","DGO THRI",147, 0)
  4116    S DGASK=$ $ANSWER^DG OTHRPT(DGD IRA,DGDIRB ,DGDIRO,DG DIRH)
  4117   "RTN","DGO THRI",148, 0)
  4118    I DGASK>0  S DGSORT( "DGVBAS")= DGASK_U_$S (DGASK=1:" VBA Adjudi cation let ter/email  received b y Registra tion staff ",DGASK=2: "VBA Adjud ication le tter recei ved by the  patient", DGASK=3:"O THER",1:"" )
  4119   "RTN","DGO THRI",149, 0)
  4120    Q DGASK>0
  4121   "RTN","DGO THRI",150, 0)
  4122    ;
  4123   "RTN","DGO THRI",151, 0)
  4124   ASKRSN(RSN NUM) ;prom pt user to  provide r eason for  reactivati on/inactiv ation
  4125   "RTN","DGO THRI",152, 0)
  4126    I RSNNUM= 1 S DGRSN= $$ANSWER^D GOTHRPT("P lease prov ide reason  for REACT IVATION (R equired)", "","F^1:60 ^K:X="" "" !(X="""")! (X?1E) X", "^D HELP^D GOTHRI(5)" )
  4127   "RTN","DGO THRI",153, 0)
  4128    I RSNNUM= 2 S DGRSN= $$ANSWER^D GOTHRPT("P lease prov ide Adjudi cation Det ails (Opti onal)","", "FO^1:60", "^D HELP^D GOTHRI(5)" )
  4129   "RTN","DGO THRI",154, 0)
  4130    I RSNNUM= 3 S DGRSN= $$ANSWER^D GOTHRPT("P lease prov ide Adjudi cation Det ails (Requ ired)","", "F^1:60^K: X="" ""!(X ="""")!(X? 1E) X","^D  HELP^DGOT HRI(5)")
  4131   "RTN","DGO THRI",155, 0)
  4132    Q DGRSN
  4133   "RTN","DGO THRI",156, 0)
  4134    ;
  4135   "RTN","DGO THRI",157, 0)
  4136   HDR1 ;
  4137   "RTN","DGO THRI",158, 0)
  4138    W !,?9,"* ********** ********** ********** ********** ********** ********** *"
  4139   "RTN","DGO THRI",159, 0)
  4140    W !,?9,"*  This opti on will RE ACTIVATE o r INACTIVA TE Other T han        *"
  4141   "RTN","DGO THRI",160, 0)
  4142    W !,?9,"*  Honorable  patient c ount down  clock in t he OTH Eli gibility   *"
  4143   "RTN","DGO THRI",161, 0)
  4144    W !,?9,"*  Clock fil e.                                                     *"
  4145   "RTN","DGO THRI",162, 0)
  4146    W !,?9,"*                                                                   *"
  4147   "RTN","DGO THRI",163, 0)
  4148    W !,?9,"*  NOTE: Ina ctivating  the Other  Than Honor able patie nt count   *"
  4149   "RTN","DGO THRI",164, 0)
  4150    W !,?9,"*        dow n clock wi ll have a  significan t effect o n the      *"
  4151   "RTN","DGO THRI",165, 0)
  4152    W !,?9,"*        tre atment of  the patien t's episod e of care.  Make      *"
  4153   "RTN","DGO THRI",166, 0)
  4154    W !,?9,"*        sur e you have  the prope r authoriz ation to i nactivate  *"
  4155   "RTN","DGO THRI",167, 0)
  4156    W !,?9,"*        the  patient's  count dow n clock.                         *"
  4157   "RTN","DGO THRI",168, 0)
  4158    W !,?9,"* ********** ********** ********** ********** ********** ********** *"
  4159   "RTN","DGO THRI",169, 0)
  4160    Q
  4161   "RTN","DGO THRI",170, 0)
  4162    ;
  4163   "RTN","DGO THRI",171, 0)
  4164   SELPAT(DGP AT) ;
  4165   "RTN","DGO THRI",172, 0)
  4166    ;- input  vars for ^ DIC call
  4167   "RTN","DGO THRI",173, 0)
  4168    N DIC,DTO UT,DUOUT,X ,Y
  4169   "RTN","DGO THRI",174, 0)
  4170    S DIC="^D GOTH(33,", DIC(0)="AE MQZV"
  4171   "RTN","DGO THRI",175, 0)
  4172    S DIC("?P ARAM",33," INDEX")=.0 1
  4173   "RTN","DGO THRI",176, 0)
  4174    ;- lookup  patient
  4175   "RTN","DGO THRI",177, 0)
  4176    D ^DIC K  DIC
  4177   "RTN","DGO THRI",178, 0)
  4178    ;- result  of lookup
  4179   "RTN","DGO THRI",179, 0)
  4180    S DGPAT=Y
  4181   "RTN","DGO THRI",180, 0)
  4182    ;- if suc cess, setu p return a rray using  output va rs from ^D IC call
  4183   "RTN","DGO THRI",181, 0)
  4184    I (+DGPAT >0) D  Q Y (0,0)  ;pa tient name
  4185   "RTN","DGO THRI",182, 0)
  4186    . S DGPAT =+Y               ;pa tient ien
  4187   "RTN","DGO THRI",183, 0)
  4188    . S DGPAT (0)=$G(Y(0 ))     ;ze ro node of  patient i n (#33) fi le
  4189   "RTN","DGO THRI",184, 0)
  4190    Q -1
  4191   "RTN","DGO THRI",185, 0)
  4192    ;
  4193   "RTN","DGO THRI",186, 0)
  4194   DEMOG(DGDF N,DGRET,DG ARR,DGPTST ) ;display  patient d emographic s
  4195   "RTN","DGO THRI",187, 0)
  4196    ;
  4197   "RTN","DGO THRI",188, 0)
  4198    N DGASK,D DASH,DFN,D GSTATE,DGE RR,VA,VADM ,VAPA
  4199   "RTN","DGO THRI",189, 0)
  4200    S DDASH=" ",$P(DDASH ,"_",80)=" "
  4201   "RTN","DGO THRI",190, 0)
  4202    S DFN=DGD FN
  4203   "RTN","DGO THRI",191, 0)
  4204    D 4^VADPT  ;extract  patient DE M and ADD
  4205   "RTN","DGO THRI",192, 0)
  4206    W @IOF
  4207   "RTN","DGO THRI",193, 0)
  4208    S @DGLIST @(DGLN,0)= " "
  4209   "RTN","DGO THRI",194, 0)
  4210    S DGLN=DG LN+1
  4211   "RTN","DGO THRI",195, 0)
  4212    S @DGLIST @(DGLN,0)= "EMERGENT  OTHER THAN  HONORABLE  PATIENT C LOCK FILE"
  4213   "RTN","DGO THRI",196, 0)
  4214    D WRITE
  4215   "RTN","DGO THRI",197, 0)
  4216    S DGLN=DG LN+1
  4217   "RTN","DGO THRI",198, 0)
  4218    S @DGLIST @(DGLN,0)= DDASH
  4219   "RTN","DGO THRI",199, 0)
  4220    D WRITE
  4221   "RTN","DGO THRI",200, 0)
  4222    S DGLN=DG LN+1
  4223   "RTN","DGO THRI",201, 0)
  4224    S @DGLIST @(DGLN,0)= "          Name:  "_$ E($G(VADM( 1)),1,25)
  4225   "RTN","DGO THRI",202, 0)
  4226    S @DGLIST @(DGLN,0)= @DGLIST@(D GLN,0)_"                 Status:   "_" ** " _$S(DGPTST =1:"ACTIVE ",DGPTST=2 :"ADJUDICA TED",DGPTS T=3:"INACT IVE",1:"") _" **"
  4227   "RTN","DGO THRI",203, 0)
  4228    D WRITE
  4229   "RTN","DGO THRI",204, 0)
  4230    S DGLN=DG LN+1
  4231   "RTN","DGO THRI",205, 0)
  4232    S @DGLIST @(DGLN,0)= "          Sex :  "_$ P($G(VADM( 5)),U,2)
  4233   "RTN","DGO THRI",206, 0)
  4234    D WRITE
  4235   "RTN","DGO THRI",207, 0)
  4236    S DGLN=DG LN+1
  4237   "RTN","DGO THRI",208, 0)
  4238    S @DGLIST @(DGLN,0)= "Date of B irth:  "_$ P($G(VADM( 3)),U,2)
  4239   "RTN","DGO THRI",209, 0)
  4240    D WRITE
  4241   "RTN","DGO THRI",210, 0)
  4242    S DGLN=DG LN+1
  4243   "RTN","DGO THRI",211, 0)
  4244    S @DGLIST @(DGLN,0)= "           SSN:  "_$ G(VA("PID" ))
  4245   "RTN","DGO THRI",212, 0)
  4246    D WRITE
  4247   "RTN","DGO THRI",213, 0)
  4248    S DGLN=DG LN+1
  4249   "RTN","DGO THRI",214, 0)
  4250    S @DGLIST @(DGLN,0)= " "
  4251   "RTN","DGO THRI",215, 0)
  4252    ;display  current OT H countdow n clock
  4253   "RTN","DGO THRI",216, 0)
  4254    I $D(DGRE T) D DSPCL CK(.DGRET)
  4255   "RTN","DGO THRI",217, 0)
  4256    S DGLN=DG LN+1
  4257   "RTN","DGO THRI",218, 0)
  4258    S @DGLIST @(DGLN,0)= DDASH
  4259   "RTN","DGO THRI",219, 0)
  4260    D WRITE
  4261   "RTN","DGO THRI",220, 0)
  4262    ;
  4263   "RTN","DGO THRI",221, 0)
  4264    I 13[DGPT ST D
  4265   "RTN","DGO THRI",222, 0)
  4266    . W !,"Ch eck displa yed data b efore proc eeding."
  4267   "RTN","DGO THRI",223, 0)
  4268    . I DGPTS T=3 W ! D  INACTMS1(D GPTNM)
  4269   "RTN","DGO THRI",224, 0)
  4270    . I '+$$E MHELG^DGOT HD1(DGDFN) !($$GET1^D IQ(2,DGDFN ,.5501,"I" )'="OTH-90 ") D INACT MS3 S DGAS K=0 Q
  4271   "RTN","DGO THRI",225, 0)
  4272    . W ! S D GASK=$$ANS WER^DGOTHR PT("Is thi s the pati ent to be  updated (Y /N)","","Y O","^D HEL P^DGOTHRI( 1)")
  4273   "RTN","DGO THRI",226, 0)
  4274    E  D VBAM SG(.DGARR)  S DGASK=1
  4275   "RTN","DGO THRI",227, 0)
  4276    D KVAR^VA DPT,KVA^VA DPT
  4277   "RTN","DGO THRI",228, 0)
  4278    Q DGASK>0
  4279   "RTN","DGO THRI",229, 0)
  4280    ;
  4281   "RTN","DGO THRI",230, 0)
  4282   WRITE ;
  4283   "RTN","DGO THRI",231, 0)
  4284    W @DGLIST @(DGLN,0), !
  4285   "RTN","DGO THRI",232, 0)
  4286    Q
  4287   "RTN","DGO THRI",233, 0)
  4288    ;
  4289   "RTN","DGO THRI",234, 0)
  4290   STATUS(DGA RR) ;displ ay OTH pat ient clock  status
  4291   "RTN","DGO THRI",235, 0)
  4292    N DGPSTAT
  4293   "RTN","DGO THRI",236, 0)
  4294    ;ACTIVE
  4295   "RTN","DGO THRI",237, 0)
  4296    I $G(DGAR R(33,DGIEN 33_",",.02 ,"I"))=1,' +$G(DGARR( 33,DGIEN33 _",",.06," I")) S DGP STAT=1
  4297   "RTN","DGO THRI",238, 0)
  4298    ;VBA ADJU DICATION C OMPLETE
  4299   "RTN","DGO THRI",239, 0)
  4300    I '$G(DGA RR(33,DGIE N33_",",.0 2,"I")),+$ G(DGARR(33 ,DGIEN33_" ,",.06,"I" )) S DGPST AT=2
  4301   "RTN","DGO THRI",240, 0)
  4302    ;INACTIVE
  4303   "RTN","DGO THRI",241, 0)
  4304    I '$G(DGA RR(33,DGIE N33_",",.0 2,"I")),'+ $G(DGARR(3 3,DGIEN33_ ",",.06,"I ")) S DGPS TAT=3
  4305   "RTN","DGO THRI",242, 0)
  4306    Q DGPSTAT
  4307   "RTN","DGO THRI",243, 0)
  4308    ;
  4309   "RTN","DGO THRI",244, 0)
  4310   DSPCLCK(DG RET) ;disp lay 365-Da y clock ov erview of  the patien t
  4311   "RTN","DGO THRI",245, 0)
  4312    ;
  4313   "RTN","DGO THRI",246, 0)
  4314    N I,DG365 ,DG90,TEXT
  4315   "RTN","DGO THRI",247, 0)
  4316    S TEXT="3 65-Day"
  4317   "RTN","DGO THRI",248, 0)
  4318    S TEXT="       "_$$B LDSTR("365 -Day",TEXT ,1,8)
  4319   "RTN","DGO THRI",249, 0)
  4320    S TEXT=$$ BLDSTR("90 -Day",TEXT ,17,9)
  4321   "RTN","DGO THRI",250, 0)
  4322    S TEXT=$$ BLDSTR("St art Date", TEXT,27,13 )
  4323   "RTN","DGO THRI",251, 0)
  4324    S TEXT=$$ BLDSTR("En d Date",TE XT,41,16)
  4325   "RTN","DGO THRI",252, 0)
  4326    S TEXT=$$ BLDSTR("Da ys Remaini ng",TEXT,5 5,19)
  4327   "RTN","DGO THRI",253, 0)
  4328    S DGLN=DG LN+1
  4329   "RTN","DGO THRI",254, 0)
  4330    S @DGLIST @(DGLN,0)= TEXT
  4331   "RTN","DGO THRI",255, 0)
  4332    W !,@DGLI ST@(DGLN,0 )
  4333   "RTN","DGO THRI",256, 0)
  4334    S TEXT="= ======"
  4335   "RTN","DGO THRI",257, 0)
  4336    S TEXT="       "_$$B LDSTR("=== ====",TEXT ,1,8)
  4337   "RTN","DGO THRI",258, 0)
  4338    S TEXT=$$ BLDSTR("== ====",TEXT ,17,9)
  4339   "RTN","DGO THRI",259, 0)
  4340    S TEXT=$$ BLDSTR("== ========", TEXT,27,13 )
  4341   "RTN","DGO THRI",260, 0)
  4342    S TEXT=$$ BLDSTR("== ========", TEXT,41,16 )
  4343   "RTN","DGO THRI",261, 0)
  4344    S TEXT=$$ BLDSTR("== ========== ==",TEXT,5 5,19)
  4345   "RTN","DGO THRI",262, 0)
  4346    S DGLN=DG LN+1
  4347   "RTN","DGO THRI",263, 0)
  4348    S @DGLIST @(DGLN,0)= TEXT
  4349   "RTN","DGO THRI",264, 0)
  4350    W !,@DGLI ST@(DGLN,0 )
  4351   "RTN","DGO THRI",265, 0)
  4352    S DGLN=DG LN+1
  4353   "RTN","DGO THRI",266, 0)
  4354    S @DGLIST @(DGLN,0)= "          "_$$BLDSTR (DGLS365D, "",1,2)
  4355   "RTN","DGO THRI",267, 0)
  4356    W !,@DGLI ST@(DGLN,0 )
  4357   "RTN","DGO THRI",268, 0)
  4358    ;
  4359   "RTN","DGO THRI",269, 0)
  4360    S DG90=""  F  S DG90 =$O(DGRET( DGLS365D,D G90)) Q:DG 90=""  D
  4361   "RTN","DGO THRI",270, 0)
  4362    . S DGRET =DGRET(DGL S365D,DG90 )
  4363   "RTN","DGO THRI",271, 0)
  4364    . S TEXT= $$BLDSTR(D G90," ",9, 2)
  4365   "RTN","DGO THRI",272, 0)
  4366    . S TEXT= $$BLDSTR($ $FMTE^XLFD T($P(DGRET ,U),"5Z"), TEXT,16,10 )
  4367   "RTN","DGO THRI",273, 0)
  4368    . S TEXT= $$BLDSTR($ $FMTE^XLFD T($P(DGRET ,U,2),"5Z" ),TEXT,30, 10)
  4369   "RTN","DGO THRI",274, 0)
  4370    . S TEXT= $$BLDSTR($ P(DGRET,U, 3),TEXT,49 ,4)
  4371   "RTN","DGO THRI",275, 0)
  4372    . I DG90> 1 S DGLN=D GLN+1 W ?1 1
  4373   "RTN","DGO THRI",276, 0)
  4374    . W TEXT, !
  4375   "RTN","DGO THRI",277, 0)
  4376    . S @DGLI ST@(DGLN,0 )="            "_TEXT
  4377   "RTN","DGO THRI",278, 0)
  4378    Q
  4379   "RTN","DGO THRI",279, 0)
  4380    ;
  4381   "RTN","DGO THRI",280, 0)
  4382   VBAMSG(DGA RR) ;displ ay VBA adj udication  message
  4383   "RTN","DGO THRI",281, 0)
  4384    ;
  4385   "RTN","DGO THRI",282, 0)
  4386    W !!,"**T he VBA adj udication  for this p atient has  been comp leted: "_D GARR(33,DG IEN33_",", .06,"E")_" ."
  4387   "RTN","DGO THRI",283, 0)
  4388    Q
  4389   "RTN","DGO THRI",284, 0)
  4390    ;
  4391   "RTN","DGO THRI",285, 0)
  4392   INACTMS1(D GPTNM) ;di splay inac tive messa ge
  4393   "RTN","DGO THRI",286, 0)
  4394    S DGLN=DG LN+1,@DGLI ST@(DGLN,0 )=" "
  4395   "RTN","DGO THRI",287, 0)
  4396    S DGLN=DG LN+1
  4397   "RTN","DGO THRI",288, 0)
  4398    S @DGLIST @(DGLN,0)= "  The Oth er Than Ho norable co untdown cl ock for pa tient "_DG PTNM
  4399   "RTN","DGO THRI",289, 0)
  4400    W !,@DGLI ST@(DGLN,0 ),!
  4401   "RTN","DGO THRI",290, 0)
  4402    S DGLN=DG LN+1
  4403   "RTN","DGO THRI",291, 0)
  4404    S @DGLIST @(DGLN,0)= "  was INA CTIVATED o n "_DGARR( 33,DGIEN33 _",",.03," E")_"."
  4405   "RTN","DGO THRI",292, 0)
  4406    W @DGLIST @(DGLN,0)
  4407   "RTN","DGO THRI",293, 0)
  4408    S DGLN=DG LN+1,@DGLI ST@(DGLN,0 )=" "
  4409   "RTN","DGO THRI",294, 0)
  4410    Q
  4411   "RTN","DGO THRI",295, 0)
  4412    ;
  4413   "RTN","DGO THRI",296, 0)
  4414   INACTMS2 ; display in active mes sage
  4415   "RTN","DGO THRI",297, 0)
  4416    W "  The  patient's  countdown  clock will  no longer  be displa yed in CPR S.",!
  4417   "RTN","DGO THRI",298, 0)
  4418    S DGLN=DG LN+1
  4419   "RTN","DGO THRI",299, 0)
  4420    S @DGLIST @(DGLN,0)= "  *** IMM EDIATE ACT ION NEEDED  ***"
  4421   "RTN","DGO THRI",300, 0)
  4422    W !,@DGLI ST@(DGLN,0 )
  4423   "RTN","DGO THRI",301, 0)
  4424    S DGLN=DG LN+1
  4425   "RTN","DGO THRI",302, 0)
  4426    S @DGLIST @(DGLN,0)= "  Go back  to Regist ration ELI GIBILITY S TATUS DATA , SCREEN 7 "
  4427   "RTN","DGO THRI",303, 0)
  4428    W !,@DGLI ST@(DGLN,0 )
  4429   "RTN","DGO THRI",304, 0)
  4430    S DGLN=DG LN+1
  4431   "RTN","DGO THRI",305, 0)
  4432    S @DGLIST @(DGLN,0)= "  and upd ate the pa tient's pr imary elig ibility co de to"
  4433   "RTN","DGO THRI",306, 0)
  4434    W !,@DGLI ST@(DGLN,0 )
  4435   "RTN","DGO THRI",307, 0)
  4436    S DGLN=DG LN+1
  4437   "RTN","DGO THRI",308, 0)
  4438    S @DGLIST @(DGLN,0)= "  its adj udicated e ligibility ."
  4439   "RTN","DGO THRI",309, 0)
  4440    W !,@DGLI ST@(DGLN,0 ),!
  4441   "RTN","DGO THRI",310, 0)
  4442    Q
  4443   "RTN","DGO THRI",311, 0)
  4444    ;
  4445   "RTN","DGO THRI",312, 0)
  4446   INACTMS3 ; display in active mes sage
  4447   "RTN","DGO THRI",313, 0)
  4448    ;user is  not allowe d to react ivate cloc k without  primary el igibility  code of
  4449   "RTN","DGO THRI",314, 0)
  4450    ;EXPANDED  MH CARE N ON-VETERAN S and EXPA NDED MH CA RE TYPE "O TH-90"
  4451   "RTN","DGO THRI",315, 0)
  4452    W !!,"  T his patien t's countd own clock  CANNOT BE  REACTIVATE D."
  4453   "RTN","DGO THRI",316, 0)
  4454    W !!,"  P lease revi ew the pat ient's eli gibility o n Registra tion"
  4455   "RTN","DGO THRI",317, 0)
  4456    W !,"  EL IGIBILITY  STATUS DAT A, SCREEN  7."
  4457   "RTN","DGO THRI",318, 0)
  4458    Q
  4459   "RTN","DGO THRI",319, 0)
  4460    ;
  4461   "RTN","DGO THRI",320, 0)
  4462   STRE(DGIEN 33,DGADJDT ,DGARR,DGL S365I,DGCL CK,DGRAIN, DGRSN,DGVB A,DGPTST)  ;stop/reac tivate OTH  patient c ount down  clock
  4463   "RTN","DGO THRI",321, 0)
  4464    ;
  4465   "RTN","DGO THRI",322, 0)
  4466    N FILENO, DGFDART,DG IENS,DGOTH ERR,DGOTH3 31,DGHSTIE N,DGFLG
  4467   "RTN","DGO THRI",323, 0)
  4468    S FILENO= 33
  4469   "RTN","DGO THRI",324, 0)
  4470    ;change P T status f rom ACTIVE  to INACTI VE or vice  versa
  4471   "RTN","DGO THRI",325, 0)
  4472    S DGFDART ($J,FILENO ,DGIEN33_" ,",.02)=DG RAIN
  4473   "RTN","DGO THRI",326, 0)
  4474    S DGFDART ($J,FILENO ,DGIEN33_" ,",.03)=$$ DT^XLFDT ; actual re- activation /inactivat ion date
  4475   "RTN","DGO THRI",327, 0)
  4476    S DGFDART ($J,FILENO ,DGIEN33_" ,",.04)=DG RSN ;reaso n/comment  for re-act ivation/in activation
  4477   "RTN","DGO THRI",328, 0)
  4478    S DGFDART ($J,FILENO ,DGIEN33_" ,",.05)=$S (DGPTST=2: "",DGADJDT >0:DGVBA,1 :"")
  4479   "RTN","DGO THRI",329, 0)
  4480    S DGFDART ($J,FILENO ,DGIEN33_" ,",.06)=$S (DGPTST=2: "",DGADJDT >0:DGADJDT ,1:"")
  4481   "RTN","DGO THRI",330, 0)
  4482    D FILE^DI E("U","DGF DART($J)", "DGOTHERR" )
  4483   "RTN","DGO THRI",331, 0)
  4484    I $D(DGOT HERR) W !! ,"An error  occurred  during fil ing." Q
  4485   "RTN","DGO THRI",332, 0)
  4486    ;create n ew/update  OTH patien t history  record
  4487   "RTN","DGO THRI",333, 0)
  4488    S DGOTH33 1=$G(^DGOT H(33.1,0))
  4489   "RTN","DGO THRI",334, 0)
  4490    Q:DGOTH33 1=""
  4491   "RTN","DGO THRI",335, 0)
  4492    S DGHSTIE N=+$O(^DGO TH(33.1,"B ",DGIEN33, 0))
  4493   "RTN","DGO THRI",336, 0)
  4494    D INSNWRE C(DGHSTIEN ,.DGARR,DG ADJDT,DGLS 365I,DGCLC K,DGRAIN,D GRSN,DGPTS T)
  4495   "RTN","DGO THRI",337, 0)
  4496    Q
  4497   "RTN","DGO THRI",338, 0)
  4498    ;
  4499   "RTN","DGO THRI",339, 0)
  4500   INSNWREC(D GHSTIEN,DG ARR,DGADJD T,DGLS365I ,DGCLCK,DG RAIN,DGRSN ,DGPTST) ;
  4501   "RTN","DGO THRI",340, 0)
  4502    N DGVALS
  4503   "RTN","DGO THRI",341, 0)
  4504    ;create n ew OTH his tory recor d
  4505   "RTN","DGO THRI",342, 0)
  4506    I DGHSTIE N=0 D
  4507   "RTN","DGO THRI",343, 0)
  4508    . S DGVAL S(.01)=DGI EN33
  4509   "RTN","DGO THRI",344, 0)
  4510    . D INSRE C^DGOTHD2( 33.1,"",.D GVALS)
  4511   "RTN","DGO THRI",345, 0)
  4512    . S DGHST IEN=+$O(^D GOTH(33.1, "B",DGIEN3 3,0))
  4513   "RTN","DGO THRI",346, 0)
  4514    N DGVALS, I
  4515   "RTN","DGO THRI",347, 0)
  4516    S DGVALS( .01)=DGLS3 65I
  4517   "RTN","DGO THRI",348, 0)
  4518    S DGVALS( .02)=DGCLC K
  4519   "RTN","DGO THRI",349, 0)
  4520    I DGPTST= 1 D
  4521   "RTN","DGO THRI",350, 0)
  4522    . I +$G(D GARR(33,DG IEN33_",", .03,"I"))  S DGPTST=3  Q
  4523   "RTN","DGO THRI",351, 0)
  4524    . I DGADJ DT>0 F I=4 :1:6 D FLD UPDTD(I)
  4525   "RTN","DGO THRI",352, 0)
  4526    I DGPTST= 2 F I=4:1: 5 D FLDUPD TD(I)
  4527   "RTN","DGO THRI",353, 0)
  4528    I DGPTST= 3 D FLDUPD TD(4)
  4529   "RTN","DGO THRI",354, 0)
  4530    Q
  4531   "RTN","DGO THRI",355, 0)
  4532    ;
  4533   "RTN","DGO THRI",356, 0)
  4534   FLDUPDTD(S CODE) ;fie ld updated
  4535   "RTN","DGO THRI",357, 0)
  4536    ;
  4537   "RTN","DGO THRI",358, 0)
  4538    I SCODE=4  D
  4539   "RTN","DGO THRI",359, 0)
  4540    . S DGVAL S(.03)=4 ; Field upda ted is OTH  Patient S tatus
  4541   "RTN","DGO THRI",360, 0)
  4542    . S DGVAL S(.04)=DGA RR(33,DGIE N33_",",.0 2,"E")
  4543   "RTN","DGO THRI",361, 0)
  4544    . S DGVAL S(.05)=$S( DGRAIN:"AC TIVE",1:"I NACTIVE")
  4545   "RTN","DGO THRI",362, 0)
  4546    . S DGVAL S(.08)=$S( $G(DGRSN)= "":"Not Pr ovided",1: DGRSN)
  4547   "RTN","DGO THRI",363, 0)
  4548    ;
  4549   "RTN","DGO THRI",364, 0)
  4550    I SCODE=5  D
  4551   "RTN","DGO THRI",365, 0)
  4552    . S DGVAL S(.03)=5 ; Field upda ted is VBA  ADJUDICAT ION STATUS
  4553   "RTN","DGO THRI",366, 0)
  4554    . S DGVAL S(.04)=$S( DGARR(33,D GIEN33_"," ,.06,"I")= "":"ADJUDI CATION PEN DING",1:"A DJUDICATIO N COMPLETE D")
  4555   "RTN","DGO THRI",367, 0)
  4556    . S DGVAL S(.05)=$S( DGADJDT>0: "ADJUDICAT ION COMPLE TED",1:"AD JUDICATION  PENDING")
  4557   "RTN","DGO THRI",368, 0)
  4558    . S DGVAL S(.08)=$P( DGSORT("DG VBAS"),U,2 )
  4559   "RTN","DGO THRI",369, 0)
  4560    ;
  4561   "RTN","DGO THRI",370, 0)
  4562    I SCODE=6  D
  4563   "RTN","DGO THRI",371, 0)
  4564    . S DGVAL S(.03)=6 ; Field upda ted is VBA  ADJUDICAT ION DATE
  4565   "RTN","DGO THRI",372, 0)
  4566    . S DGVAL S(.04)=$S( DGARR(33,D GIEN33_"," ,.06,"I")= "":DGADJDT ,1:DGARR(3 3,DGIEN33_ ",",.06,"I "))
  4567   "RTN","DGO THRI",373, 0)
  4568    . S DGVAL S(.05)=DGA DJDT
  4569   "RTN","DGO THRI",374, 0)
  4570    . S DGVAL S(.08)=$P( DGSORT("DG VBAS"),U,2 )
  4571   "RTN","DGO THRI",375, 0)
  4572    ;
  4573   "RTN","DGO THRI",376, 0)
  4574    D EDTBY
  4575   "RTN","DGO THRI",377, 0)
  4576    D INSREC^ DGOTHD2(33 .12,DGHSTI EN,.DGVALS )
  4577   "RTN","DGO THRI",378, 0)
  4578    Q
  4579   "RTN","DGO THRI",379, 0)
  4580    ;
  4581   "RTN","DGO THRI",380, 0)
  4582   EDTBY ;
  4583   "RTN","DGO THRI",381, 0)
  4584    S DGVALS( .06)=$S($G (DUZ)>0:$$ GET1^DIQ(2 00,DUZ,.01 ),1:"POSTM ASTER")
  4585   "RTN","DGO THRI",382, 0)
  4586    S DGVALS( .07)=$$NOW ^XLFDT
  4587   "RTN","DGO THRI",383, 0)
  4588    Q
  4589   "RTN","DGO THRI",384, 0)
  4590    ;
  4591   "RTN","DGO THRI",385, 0)
  4592   HELP(DGSEL ) ;provide  extended  DIR("?") h elp text.
  4593   "RTN","DGO THRI",386, 0)
  4594    ;
  4595   "RTN","DGO THRI",387, 0)
  4596    I X'="?", X'="??" W  !,"  Not a  valid ans wer.",!
  4597   "RTN","DGO THRI",388, 0)
  4598    I DGSEL=1  D
  4599   "RTN","DGO THRI",389, 0)
  4600    . W !,"   Enter 'Y'  - if this  is the pat ient you a re looking  to be upd ated."
  4601   "RTN","DGO THRI",390, 0)
  4602    I DGSEL=2  D
  4603   "RTN","DGO THRI",391, 0)
  4604    . W !,"   Enter 'Y'  - if you r eceived in formation  regarding"
  4605   "RTN","DGO THRI",392, 0)
  4606    . W !,"                the pati ent's Adju dication S tatus."
  4607   "RTN","DGO THRI",393, 0)
  4608    I DGSEL=3  D
  4609   "RTN","DGO THRI",394, 0)
  4610    . W !,"   Enter the  actual adj udication  date based  on the in formation  you receiv ed"
  4611   "RTN","DGO THRI",395, 0)
  4612    . W !,"   regarding  the patien t's Adjudi cation Sta tus."
  4613   "RTN","DGO THRI",396, 0)
  4614    . W !!,"   The adjud ication da te should  not be pri or to the  patient's"
  4615   "RTN","DGO THRI",397, 0)
  4616    . W !,"   1st 90-Day  period of  care star t date."
  4617   "RTN","DGO THRI",398, 0)
  4618    I DGSEL=4  D
  4619   "RTN","DGO THRI",399, 0)
  4620    . W !,"   Enter 'Y'  - if this  is the pat ient you w ould like  to INACTIV ATE/REACTI VATE."
  4621   "RTN","DGO THRI",400, 0)
  4622    I DGSEL=5  D
  4623   "RTN","DGO THRI",401, 0)
  4624    . W !,"   Answer mus t be 1-60  characters  in length .",!
  4625   "RTN","DGO THRI",402, 0)
  4626    . W !,"   Enter the  reason or  details fo r reactiva tion/inact ivation of  the",!,"   OTH patie nt's count down clock ."
  4627   "RTN","DGO THRI",403, 0)
  4628    . W !,"   For exampl e: VBA Adj udication  Reference  number, ty pe of adju dication,  etc."
  4629   "RTN","DGO THRI",404, 0)
  4630    I 124[DGS EL W !!,"   Otherwise , enter 'N '"
  4631   "RTN","DGO THRI",405, 0)
  4632    Q
  4633   "RTN","DGO THRI",406, 0)
  4634    ;
  4635   "RTN","DGO THRI",407, 0)
  4636   SNDMAIL ;s end mail t o DUZ
  4637   "RTN","DGO THRI",408, 0)
  4638    ;
  4639   "RTN","DGO THRI",409, 0)
  4640    N X,MES,Z TRTN,ZTDES C,ZTIO,ZTD TH,ZTREQ,Z TSK,ZTSAVE
  4641   "RTN","DGO THRI",410, 0)
  4642    N DIFROM, XMDUZ,XMSU B,XMTEXT,X MY
  4643   "RTN","DGO THRI",411, 0)
  4644    W !,"  A  copy of th is informa tion has b een forwar ded to you r email"
  4645   "RTN","DGO THRI",412, 0)
  4646    W !,"  fo r referenc e."
  4647   "RTN","DGO THRI",413, 0)
  4648    S XMSUB=" URGENT: UP DATE PRIMA RY ELIGIBI LITY FOR P ATIENT "_D GPTNM
  4649   "RTN","DGO THRI",414, 0)
  4650    S XMDUZ="
P II             "
  4651   "RTN","DGO THRI",415, 0)
  4652    S XMTEXT= "^TMP(""OT H90"",$J,"
  4653   "RTN","DGO THRI",416, 0)
  4654    S (XMY(DU Z),XMY(.5) )=""
  4655   "RTN","DGO THRI",417, 0)
  4656    D NOW^%DT C S Y=% D  DD^%DT
  4657   "RTN","DGO THRI",418, 0)
  4658    D ^XMD
  4659   "RTN","DGO THRI",419, 0)
  4660    Q
  4661   "RTN","DGO THRI",420, 0)
  4662    ;
  4663   "RTN","DGO THRI",421, 0)
  4664   BLDSTR(NST R,STR,COL, NSL) ;buil d a string
  4665   "RTN","DGO THRI",422, 0)
  4666    Q $E(STR_ $J("",COL- 1),1,COL-1 )_$E(NSTR_ $J("",NSL) ,1,NSL)_$E (STR,COL+N SL,999)
  4667   "RTN","DGO THRI",423, 0)
  4668    ;
  4669   "RTN","DGO THRP1")
  4670   0^10^B6607 2210
  4671   "RTN","DGO THRP1",1,0 )
  4672   DGOTHRP1 ; SLC/RED -  OTHD (OTHE R THAN HON ORABLE DIS CHARGE) Re ports ;May  9,2018@05 :08
  4673   "RTN","DGO THRP1",2,0 )
  4674    ;;5.3;Reg istration; **952**;Ma y 9, 2018; Build 68
  4675   "RTN","DGO THRP1",3,0 )
  4676    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  4677   "RTN","DGO THRP1",4,0 )
  4678    ;
  4679   "RTN","DGO THRP1",5,0 )
  4680    ;     Las t Edited:  SHRPE/RED  - August 1 5, 2018 15 :00
  4681   "RTN","DGO THRP1",6,0 )
  4682    ;
  4683   "RTN","DGO THRP1",7,0 )
  4684     ;
  4685   "RTN","DGO THRP1",8,0 )
  4686    ;  IA:  1 0103   ^XL FDT (sup)   - [$$FMAD D^XLFDT, $ $FMTE^XLFD T , $$NOW^ XLFDT]
  4687   "RTN","DGO THRP1",9,0 )
  4688    ;          10015   ^ DIQ    (su p)  - [GET S^DIQ]
  4689   "RTN","DGO THRP1",10, 0)
  4690    ;          10026     ^DIR   (su p)
  4691   "RTN","DGO THRP1",11, 0)
  4692    ;          10061     PID^VADPT  (sup)
  4693   "RTN","DGO THRP1",12, 0)
  4694    ;          10063     ^%ZTLOAD ( sup)
  4695   "RTN","DGO THRP1",13, 0)
  4696    ;          10089     ^%ZISC  (s up)
  4697   "RTN","DGO THRP1",14, 0)
  4698    ;
  4699   "RTN","DGO THRP1",15, 0)
  4700    Q  ; No D irect acce ss
  4701   "RTN","DGO THRP1",16, 0)
  4702    ;
  4703   "RTN","DGO THRP1",17, 0)
  4704   REPORT ;   Access by  Option nam e: DG OTH  EXCEPTION  REPORT
  4705   "RTN","DGO THRP1",18, 0)
  4706    ;
  4707   "RTN","DGO THRP1",19, 0)
  4708    N DGIEN,D GARR,DGIEN 33,DGTYPE, DASH,DGQUI T,DGART,DG CNT,PAGE,E XIT,DGSP1, DGEP1,DGSP 2,DGEP2,DG LOOP,DGDAY 1,DGDAY2,D GEND
  4709   "RTN","DGO THRP1",20, 0)
  4710    N HDR,HDR 1,HDR2,X,D GNAME,DTOU T,DUOUT,PO P,ZTDESC,Z TRTN,ZTSAV E,ZTSK,PID
  4711   "RTN","DGO THRP1",21, 0)
  4712    S DASH="" ,$P(DASH," -",81)="", EXIT=0,PAG E=1
  4713   "RTN","DGO THRP1",22, 0)
  4714    S DGARR=$ NA(^TMP($J ,"DGOTHRP1 ")) K @DGA RR
  4715   "RTN","DGO THRP1",23, 0)
  4716    S @DGARR@ (0)="OTH E XCEPTION R EPORT"
  4717   "RTN","DGO THRP1",24, 0)
  4718    K DIRUT,Y ,DIR ; Exc eption rep ort prompt
  4719   "RTN","DGO THRP1",25, 0)
  4720    S DIR(0)= "S^1:1st 9 0 day peri od has exp ired, no A uth for 2n d period;2 :Both 90 d ay periods  have expi red;3:Repo rt of pati ents witho ut a start  date (1st ) period o f care;4:2 nd 90 day  period is  authorized  but never  started"
  4721   "RTN","DGO THRP1",26, 0)
  4722    S DIR("A" )="Other t han honora ble except ion report  type"
  4723   "RTN","DGO THRP1",27, 0)
  4724    D ^DIR K  DIR Q:$D(D IRUT)
  4725   "RTN","DGO THRP1",28, 0)
  4726    S DGTYPE= Y,DGQUIT=" "
  4727   "RTN","DGO THRP1",29, 0)
  4728    Q:DGTYPE= U
  4729   "RTN","DGO THRP1",30, 0)
  4730    S HDR="Ot her than H onorable E xception R eport"
  4731   "RTN","DGO THRP1",31, 0)
  4732    S HDR1=Y( 0)
  4733   "RTN","DGO THRP1",32, 0)
  4734    S HDR2="P rinted Dat e/Time: "_ $$FMTE^XLF DT($$NOW^X LFDT(),1)
  4735   "RTN","DGO THRP1",33, 0)
  4736    S DGEND=D T
  4737   "RTN","DGO THRP1",34, 0)
  4738    D DEV  ;A llow queue ing
  4739   "RTN","DGO THRP1",35, 0)
  4740    ;
  4741   "RTN","DGO THRP1",36, 0)
  4742   EN ; Repor t entry po int if Que ued
  4743   "RTN","DGO THRP1",37, 0)
  4744    S (DGIEN3 3,DGIEN,DG LOOP,DGCNT )=0
  4745   "RTN","DGO THRP1",38, 0)
  4746    F  S DGIE N33=$O(^DG OTH(33,DGI EN33)) Q:' DGIEN33!(E XIT)  D
  4747   "RTN","DGO THRP1",39, 0)
  4748    . K DGART  D GETS^DI Q(33,DGIEN 33_",",".0 1;.02;.03; 1*","IE"," DGART")
  4749   "RTN","DGO THRP1",40, 0)
  4750    . Q:DGART (33,DGIEN3 3_",",.03, "I")  ;Adj udication  was comple ted
  4751   "RTN","DGO THRP1",41, 0)
  4752    . S DGSP1 =$G(DGART( 33.11,"1,1 ,"_DGIEN33 _",",.02," I")),DGEP1 =$$FMADD^X LFDT(DGSP1 ,90)  ;End  date Peri od #1
  4753   "RTN","DGO THRP1",42, 0)
  4754    . I DGEP1 <0 S DGEP1 =""
  4755   "RTN","DGO THRP1",43, 0)
  4756    . I DGTYP E'=3,'DGSP 1 Q
  4757   "RTN","DGO THRP1",44, 0)
  4758    . S DGSP2 =$G(DGART( 33.11,"2,1 ,"_DGIEN33 _",",.02," I")),DGEP2 =$$FMADD^X LFDT(DGSP2 ,90)  ;End  date Peri od #2
  4759   "RTN","DGO THRP1",45, 0)
  4760    . I DGEP2 <0 S DGEP2 =""
  4761   "RTN","DGO THRP1",46, 0)
  4762    . K PID S  PID=$$GET 1^DIQ(2,DG ART(33,DGI EN33_",",. 01,"I"),". 0905","E")
  4763   "RTN","DGO THRP1",47, 0)
  4764    . ;S DFN= DGART(33,D GIEN33_"," ,.01,"I")  D PID^VADP T6 S PID=$ S(VA("BID" )]"":VA("B ID"),1:"UN KNOWN") K  VA("PID")
  4765   "RTN","DGO THRP1",48, 0)
  4766    . S DGDAY 1=$S(DGEP1 <DT:"0",DG SP1>DT:"90 ",1:$$FMDI FF^XLFDT(D GEP1,DT,1) )
  4767   "RTN","DGO THRP1",49, 0)
  4768    . S DGDAY 2=$S(DGSP2 ="":"",DGE P2<DT:"",D GSP2>DT:"9 0",1:$$FMD IFF^XLFDT( DGEP2,DT,1 ))
  4769   "RTN","DGO THRP1",50, 0)
  4770    . D @DGTY PE S DGLOO P=DGLOOP+1
  4771   "RTN","DGO THRP1",51, 0)
  4772    . K DGART
  4773   "RTN","DGO THRP1",52, 0)
  4774    . Q
  4775   "RTN","DGO THRP1",53, 0)
  4776    Q:EXIT
  4777   "RTN","DGO THRP1",54, 0)
  4778    D PRINT
  4779   "RTN","DGO THRP1",55, 0)
  4780    W !,"Tota l ",$S(DGC NT=1:"pati ent",1:"pa tients"),"  found on  this repor t: ",DGCNT ,!
  4781   "RTN","DGO THRP1",56, 0)
  4782    I DGCNT=0  D HDR W ! ?5," No re cords were  found usi ng the rep ort criter ia.",!!
  4783   "RTN","DGO THRP1",57, 0)
  4784    I $E(IOST ,1,1)="C-"  R !!,"END  OF REPORT ...PRESS R ETURN TO C ONTINUE",X :DTIME W @ IOF
  4785   "RTN","DGO THRP1",58, 0)
  4786    D ^%ZISC  K @DGARR
  4787   "RTN","DGO THRP1",59, 0)
  4788    Q
  4789   "RTN","DGO THRP1",60, 0)
  4790   1 ;                                                                                                                         1st 90  day period  has expir ed, no Aut h for 2nd  period
  4791   "RTN","DGO THRP1",61, 0)
  4792    I DGLOOP= 0 D HDR
  4793   "RTN","DGO THRP1",62, 0)
  4794    I $G(DGAR T(33.11,"2 ,1,"_DGIEN 33_",",.07 ,"I"))'=""  S DGLOOP= DGLOOP+1 Q
  4795   "RTN","DGO THRP1",63, 0)
  4796    I DGEP1>D T Q
  4797   "RTN","DGO THRP1",64, 0)
  4798    D BUILD S  DGCNT=DGC NT+1
  4799   "RTN","DGO THRP1",65, 0)
  4800    Q
  4801   "RTN","DGO THRP1",66, 0)
  4802   2 ;                                                                                                                         Both 90  day perio ds have ex pired
  4803   "RTN","DGO THRP1",67, 0)
  4804    I DGLOOP= 0 D HDR
  4805   "RTN","DGO THRP1",68, 0)
  4806    I DGDAY2  S DGLOOP=D GLOOP+1 Q
  4807   "RTN","DGO THRP1",69, 0)
  4808    I 'DGSP2  S DGLOOP=D GLOOP+1 Q
  4809   "RTN","DGO THRP1",70, 0)
  4810    D BUILD S  DGCNT=DGC NT+1
  4811   "RTN","DGO THRP1",71, 0)
  4812    Q
  4813   "RTN","DGO THRP1",72, 0)
  4814    ;
  4815   "RTN","DGO THRP1",73, 0)
  4816   3 ;                                                                                                                          Report  of patien ts without  a start d ate for 1s t period o f care
  4817   "RTN","DGO THRP1",74, 0)
  4818    I DGLOOP= 0 D HDR
  4819   "RTN","DGO THRP1",75, 0)
  4820    I DGSP1 S  DGLOOP=DG LOOP+1 Q
  4821   "RTN","DGO THRP1",76, 0)
  4822    ;I DGSP1& '$D(DGART( 33.11,"2,1 ,"_DGIEN33 _",")) S D GLOOP=DGLO OP+1 Q
  4823   "RTN","DGO THRP1",77, 0)
  4824    D BUILD S  DGCNT=DGC NT+1
  4825   "RTN","DGO THRP1",78, 0)
  4826     Q
  4827   "RTN","DGO THRP1",79, 0)
  4828    ;
  4829   "RTN","DGO THRP1",80, 0)
  4830   4 ;                                                                                                                          2nd 90  day perio d is autho rized but  never star ted
  4831   "RTN","DGO THRP1",81, 0)
  4832    I DGLOOP= 0 D HDR
  4833   "RTN","DGO THRP1",82, 0)
  4834    I $G(DGAR T(33.11,"2 ,1,"_DGIEN 33_",",.07 ,"I")),DGS P2 S DGLOO P=DGLOOP+1  Q
  4835   "RTN","DGO THRP1",83, 0)
  4836    I $G(DGAR T(33.11,"2 ,1,"_DGIEN 33_",",.07 ,"I")),DGS P2<DT S DG LOOP=DGLOO P+1 Q
  4837   "RTN","DGO THRP1",84, 0)
  4838    I DGDAY2, DGDAY2<90  S DGLOOP=D GLOOP+1 Q
  4839   "RTN","DGO THRP1",85, 0)
  4840    I '$D(DGA RT(33.11," 2,1,"_DGIE N33_",",.0 7,"I")) S  DGLOOP=DGL OOP+1 Q
  4841   "RTN","DGO THRP1",86, 0)
  4842    I DGSP2'= "",DGSP2<( DT+1) S DG LOOP=DGLOO P+1 Q
  4843   "RTN","DGO THRP1",87, 0)
  4844    D BUILD S  DGCNT=DGC NT+1
  4845   "RTN","DGO THRP1",88, 0)
  4846    Q
  4847   "RTN","DGO THRP1",89, 0)
  4848    ;
  4849   "RTN","DGO THRP1",90, 0)
  4850   HDR ;
  4851   "RTN","DGO THRP1",91, 0)
  4852    U IO
  4853   "RTN","DGO THRP1",92, 0)
  4854    W @IOF,?( 80-$L(HDR) /2),HDR,?7 2,"PAGE "_ PAGE,!?(80 -$L(HDR1)/ 2),HDR1,!? (80-$L(HDR 2)/2),HDR2 ,!
  4855   "RTN","DGO THRP1",93, 0)
  4856    W !,"Pati ent Name", ?32,"PID", ?45,"Perio d",?55,"St art Date", ?70,"End D ate"  ;I D GTYPE=4 W  ?70,"Days  Left"
  4857   "RTN","DGO THRP1",94, 0)
  4858    W !,DASH  S PAGE=PAG E+1
  4859   "RTN","DGO THRP1",95, 0)
  4860    Q
  4861   "RTN","DGO THRP1",96, 0)
  4862    ;
  4863   "RTN","DGO THRP1",97, 0)
  4864   DEV ;
  4865   "RTN","DGO THRP1",98, 0)
  4866    N DIR,DIR UT,Y
  4867   "RTN","DGO THRP1",99, 0)
  4868     W ! S %Z IS="Q" D ^ %ZIS I POP  Q
  4869   "RTN","DGO THRP1",100 ,0)
  4870    I $D(IO(" Q")) D  D  ^%ZTLOAD K  IO("Q"),Z TSK Q
  4871   "RTN","DGO THRP1",101 ,0)
  4872    . S ZTDES C="Other t han Honora ble Except ion Report ",ZTRTN="E N^DGOTHRP1 "
  4873   "RTN","DGO THRP1",102 ,0)
  4874    . S ZTSAV E("DGTYPE" )="",ZTSAV E("HDR")=" ",ZTSAVE(" HDR1")="", ZTSAVE("HD R2")="",ZT SAVE("ZTRE Q")="@"
  4875   "RTN","DGO THRP1",103 ,0)
  4876    I $G(ZTSK ) W !!,"Re port compi lation has  started w ith task#  ",ZTSK,"." ,! S DIR(0 )="E" D ^D IR K DIR
  4877   "RTN","DGO THRP1",104 ,0)
  4878    Q
  4879   "RTN","DGO THRP1",105 ,0)
  4880    ;
  4881   "RTN","DGO THRP1",106 ,0)
  4882   BUILD ;    Builds arr ay - ^TMP( $J,"DGOTHR P1",DGNAME ,SUBSCRIPT )
  4883   "RTN","DGO THRP1",107 ,0)
  4884    S DGNAME= $E(DGART(3 3,DGIEN33_ ",",.01,"E "),1,28)
  4885   "RTN","DGO THRP1",108 ,0)
  4886    S @DGARR@ (DGNAME,1) =DGNAME_U_ PID_U_"1"_ U_$$FMTE^X LFDT(DGSP1 ,"5Z")_U_$ $FMTE^XLFD T(DGEP1,"5 Z")
  4887   "RTN","DGO THRP1",109 ,0)
  4888    I DGTYPE' =3 S @DGAR R@(DGNAME, 2)="2"_U_$ S(DGSP2:$$ FMTE^XLFDT (DGSP2,"5Z "),1:"No s tart date" )_U_$$FMTE ^XLFDT(DGE P2,"5Z") I  DGTYPE=4  S $P(@DGAR R@(DGNAME, 2),U,4)=DG DAY2
  4889   "RTN","DGO THRP1",110 ,0)
  4890    Q
  4891   "RTN","DGO THRP1",111 ,0)
  4892   PRINT ;
  4893   "RTN","DGO THRP1",112 ,0)
  4894    N I S I=1  F  S I=$O (@DGARR@(I )) Q:I=""! (EXIT)  D
  4895   "RTN","DGO THRP1",113 ,0)
  4896    . I $Y+4> IOSL D
  4897   "RTN","DGO THRP1",114 ,0)
  4898    ..W !
  4899   "RTN","DGO THRP1",115 ,0)
  4900    .. I $E(I OST,1,2)=" C-" S DIR( 0)="E" K D IRUT D ^DI R
  4901   "RTN","DGO THRP1",116 ,0)
  4902    .. I $D(D IRUT)!$D(D UOUT)!$D(D TOUT) S EX IT=1 Q  ;U ser exited  the repor t
  4903   "RTN","DGO THRP1",117 ,0)
  4904    .. D HDR
  4905   "RTN","DGO THRP1",118 ,0)
  4906    . W !,$P( @DGARR@(I, 1),U),?32, $P(@DGARR@ (I,1),U,2) ,?48,$P(@D GARR@(I,1) ,U,3),?55, $P(@DGARR@ (I,1),U,4) ,?70,$P(@D GARR@(I,1) ,U,5) ;I D GTYPE=4 W  ?74,$P(@DG ARR@(I,1), U,6)
  4907   "RTN","DGO THRP1",119 ,0)
  4908    . I 13'[D GTYPE W !? 48,$P(@DGA RR@(I,2),U ),?55,$P(@ DGARR@(I,2 ),U,2),?70 ,$P(@DGARR @(I,2),U,3 ) ;I DGTYP E=4 W ?74, $P(@DGARR@ (I,2),U,4)  Q
  4909   "RTN","DGO THRP1",120 ,0)
  4910    . W !
  4911   "RTN","DGO THRP1",121 ,0)
  4912    Q
  4913   "RTN","DGO THRP1",122 ,0)
  4914    ;
  4915   "RTN","DGO THRP1",123 ,0)
  4916   INACRPT ;
  4917   "RTN","DGO THRP1",124 ,0)
  4918    N DGIEN,D GART,DGIEN 33,DGINTDT ,DGDTEND,D GSTDT,PID, DG331,DGIN A0,PAGE,EX IT,DGTIME
  4919   "RTN","DGO THRP1",125 ,0)
  4920    S (DGIEN3 3,DGIEN,DG LOOP,DGCNT ,DGINTDT,E XIT)=0
  4921   "RTN","DGO THRP1",126 ,0)
  4922    D DATESEL    ;get da te selecti on for rep ort
  4923   "RTN","DGO THRP1",127 ,0)
  4924    Q:EXIT
  4925   "RTN","DGO THRP1",128 ,0)
  4926    D INADEV
  4927   "RTN","DGO THRP1",129 ,0)
  4928    ;
  4929   "RTN","DGO THRP1",130 ,0)
  4930   INAEN ; En try point  if Queued
  4931   "RTN","DGO THRP1",131 ,0)
  4932    I $E(IOST )="C" D WA IT^DICD
  4933   "RTN","DGO THRP1",132 ,0)
  4934    K DGARR
  4935   "RTN","DGO THRP1",133 ,0)
  4936    F  S DGIE N33=$O(^DG OTH(33,DGI EN33)) Q:' DGIEN33  D
  4937   "RTN","DGO THRP1",134 ,0)
  4938    . K DGART  D GETS^DI Q(33,DGIEN 33_",",".0 1;.02;.03; 1*","IE"," DGART")
  4939   "RTN","DGO THRP1",135 ,0)
  4940    . I DGART (33,DGIEN3 3_",",.02, "I")'=0  ; No inactiv ation/reac tivation d ate on fil e
  4941   "RTN","DGO THRP1",136 ,0)
  4942    . S DGINT DT=$G(DGAR T(33,DGIEN 33_",",.03 ,"I"))
  4943   "RTN","DGO THRP1",137 ,0)
  4944    . I DGINT DT<DGSTDT! (DGINTDT>D GDTEND) Q
  4945   "RTN","DGO THRP1",138 ,0)
  4946    . S DG331 ="",DG331= $O(^DGOTH( 33.1,"B",D GIEN33,0))
  4947   "RTN","DGO THRP1",139 ,0)
  4948    . Q:DG331 =""
  4949   "RTN","DGO THRP1",140 ,0)
  4950    . S PID=$ $GET1^DIQ( 2,DGART(33 ,DGIEN33_" ,",.01,"I" ),".0905", "E")
  4951   "RTN","DGO THRP1",141 ,0)
  4952    . K DGINA 0 S X=.8 F   S X=$O(^ DGOTH(33.1 ,DG331,1,X )) Q:'X  D
  4953   "RTN","DGO THRP1",142 ,0)
  4954    .. Q:$P(^ DGOTH(33.1 ,DG331,1,X ,0),U,3)'= 4
  4955   "RTN","DGO THRP1",143 ,0)
  4956    .. S DGIN A0=^DGOTH( 33.1,DG331 ,1,X,0) Q: $G(DGINA0) =""
  4957   "RTN","DGO THRP1",144 ,0)
  4958    .. K DGTI ME S DGTIM E=$P($$FMT E^XLFDT($P (DGINA0,U, 7),"5Z")," :",1,2)
  4959   "RTN","DGO THRP1",145 ,0)
  4960    .. S DGAR R(DGART(33 ,DGIEN33_" ,",.01,"E" ),X)=$E(DG ART(33,DGI EN33_",",. 01,"E"),1, 22)_U_PID_ U_$P(DGINA 0,U,5)_U_D GTIME_U_$P (DGINA0,U, 6)
  4961   "RTN","DGO THRP1",146 ,0)
  4962    I $D(DGAR R)=0 W !," No patient s found fo r this tim e frame",!  Q
  4963   "RTN","DGO THRP1",147 ,0)
  4964    W # S PAG E=1 D PRTH DR,PRTINA  W !!,?15," <END OF RE PORT>",!!
  4965   "RTN","DGO THRP1",148 ,0)
  4966    Q
  4967   "RTN","DGO THRP1",149 ,0)
  4968   PRTHDR ;
  4969   "RTN","DGO THRP1",150 ,0)
  4970    W @IOF,!? 12,"INACTI VATE/REACT IVATE, OTH  PT CLOCK  REPORT",?7 0,"Page: " ,PAGE
  4971   "RTN","DGO THRP1",151 ,0)
  4972    W !?12,"S elected da te range:  ",$$FMTE^X LFDT(DGSTD T,"5Z"),"  to ",$$FMT E^XLFDT(DG DTEND,"5Z" )
  4973   "RTN","DGO THRP1",152 ,0)
  4974    W !,"Pati ent",?23," PID",?30," I/R",?40," Date Time" ,?55,"Edit ed by",!
  4975   "RTN","DGO THRP1",153 ,0)
  4976    F DASH=1: 1:75 W "-"
  4977   "RTN","DGO THRP1",154 ,0)
  4978    Q
  4979   "RTN","DGO THRP1",155 ,0)
  4980   PRTINA ;
  4981   "RTN","DGO THRP1",156 ,0)
  4982    N I,J S I ="",(EXIT, J)=0
  4983   "RTN","DGO THRP1",157 ,0)
  4984    F  S I=$O (DGARR(I))  Q:I=""!(E XIT)  D
  4985   "RTN","DGO THRP1",158 ,0)
  4986    . F  S J= $O(DGARR(I ,J)) Q:'J   D
  4987   "RTN","DGO THRP1",159 ,0)
  4988    ..I $Y+4> IOSL D  Q: EXIT
  4989   "RTN","DGO THRP1",160 ,0)
  4990    ...K DTOU T,DIRUT
  4991   "RTN","DGO THRP1",161 ,0)
  4992    ...I $E(I OST,1,2)=" C-" S DIR( 0)="E" D ^ DIR K DIR
  4993   "RTN","DGO THRP1",162 ,0)
  4994    ...I $G(D IRUT) S EX IT=1 G EXI T  ;User e xited the  report
  4995   "RTN","DGO THRP1",163 ,0)
  4996    ...S PAGE =PAGE+1 D  PRTHDR
  4997   "RTN","DGO THRP1",164 ,0)
  4998    .. Q:EXIT
  4999   "RTN","DGO THRP1",165 ,0)
  5000    .. W !,$P (DGARR(I,J ),U),?23,$ P(DGARR(I, J),U,2),?3 1,$S($E($P (DGARR(I,J ),U,3),1)= "A":"R",1: $E($P(DGAR R(I,J),U,3 ),1)),?36, $P(DGARR(I ,J),U,4),? 55,$E($$GE T1^DIQ(200 ,$P(DGARR( I,J),U,5)_ ",",.01),1 ,20)
  5001   "RTN","DGO THRP1",166 ,0)
  5002    Q
  5003   "RTN","DGO THRP1",167 ,0)
  5004    ;
  5005   "RTN","DGO THRP1",168 ,0)
  5006   DATESEL ;   select st arting and  ending da tes in day s
  5007   "RTN","DGO THRP1",169 ,0)
  5008    ;  return s DGSTDT a nd DGDTEND
  5009   "RTN","DGO THRP1",170 ,0)
  5010    N %,%DT,% H,%I,DEFAU LT,X,Y,DES CR
  5011   "RTN","DGO THRP1",171 ,0)
  5012   STARTDT S  DESCR=""
  5013   "RTN","DGO THRP1",172 ,0)
  5014    S Y=$E(DT ,1,5)_"01"  D DD^%DT  S DEFAULT= Y
  5015   "RTN","DGO THRP1",173 ,0)
  5016    S %DT("A" )="Start w ith "_$S(D ESCR'="":D ESCR_" ",1 :"")_"Date : ",%DT="A EP",%DT(0) =-DT D ^%D T I Y<0,X' ="^"  W !? 25,"A date  is requir ed" G STAR TDT
  5017   "RTN","DGO THRP1",174 ,0)
  5018    I X="^" W  !!?20,"Ex iting as p er request " S EXIT=1  Q  ; Vari able X con tains the  actual ent ry from th e User.
  5019   "RTN","DGO THRP1",175 ,0)
  5020    I $E(Y,6, 7)="00" S  Y=$E(Y,1,5 )_"01"
  5021   "RTN","DGO THRP1",176 ,0)
  5022    S DGSTDT= Y
  5023   "RTN","DGO THRP1",177 ,0)
  5024    S Y=DT D  DD^%DT S D EFAULT=Y
  5025   "RTN","DGO THRP1",178 ,0)
  5026    S %DT("A" )="  End w ith "_$S(D ESCR'="":D ESCR_" ",1 :"")_"Date : ",%DT("B ")=DEFAULT ,%DT="AEP" ,%DT(0)=-D T D ^%DT I  Y<0 Q
  5027   "RTN","DGO THRP1",179 ,0)
  5028    I $E(Y,6, 7)="00" S  Y=$E(Y,1,5 )_"01"
  5029   "RTN","DGO THRP1",180 ,0)
  5030    I Y<DGSTD T W !,"END  DATE MUST  BE GREATE R THAN OR  EQUAL TO T HE START D ATE.",! G  STARTDT
  5031   "RTN","DGO THRP1",181 ,0)
  5032    S DGDTEND =Y,Y=DGSTD T D DD^%DT
  5033   "RTN","DGO THRP1",182 ,0)
  5034    Q
  5035   "RTN","DGO THRP1",183 ,0)
  5036   INADEV ;
  5037   "RTN","DGO THRP1",184 ,0)
  5038    N DIR,DIR UT,Y
  5039   "RTN","DGO THRP1",185 ,0)
  5040     W ! S %Z IS="Q" D ^ %ZIS I POP  Q
  5041   "RTN","DGO THRP1",186 ,0)
  5042    I $D(IO(" Q")) D  D  ^%ZTLOAD K  IO("Q"),Z TSK Q
  5043   "RTN","DGO THRP1",187 ,0)
  5044    . S ZTDES C="Other t han Honora ble Except ion Inacti vation rep ort",ZTRTN ="INAEN^DG OTHRP1"
  5045   "RTN","DGO THRP1",188 ,0)
  5046    . S ZTSAV E("DGSTDT" )="",ZTSAV E("DGDTEND ")="",ZTSA VE("ZTREQ" )="@"
  5047   "RTN","DGO THRP1",189 ,0)
  5048    I $G(ZTSK ) W !!,"Re port compi lation has  started w ith task#  ",ZTSK,"." ,! S DIR(0 )="E" D ^D IR K DIR
  5049   "RTN","DGO THRP1",190 ,0)
  5050    Q
  5051   "RTN","DGO THRP1",191 ,0)
  5052   EXIT ;
  5053   "RTN","DGO THRP1",192 ,0)
  5054    Q
  5055   "RTN","DGO THRP1",193 ,0)
  5056    ;
  5057   "RTN","DGO THRP1",194 ,0)
  5058    ;END OF D GOTHRP1
  5059   "RTN","DGO THRP2")
  5060   0^9^B37660 217
  5061   "RTN","DGO THRP2",1,0 )
  5062   DGOTHRP2 ; SLC/RM - O TH PATIENT  PERIOD ST ATUS REPOR T CONT. ;M AY 8, 2018 @5:15
  5063   "RTN","DGO THRP2",2,0 )
  5064    ;;5.3;Reg istration; **952**;Au g 13, 1993 ;Build 68
  5065   "RTN","DGO THRP2",3,0 )
  5066    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d
  5067   "RTN","DGO THRP2",4,0 )
  5068    ;
  5069   "RTN","DGO THRP2",5,0 )
  5070    ;     Las t Edited:  SHRPE/RM -  MAY 8, 20 18 17:15
  5071   "RTN","DGO THRP2",6,0 )
  5072    ;
  5073   "RTN","DGO THRP2",7,0 )
  5074    ; ICR# TY PE      DE SCRIPTION
  5075   "RTN","DGO THRP2",8,0 )
  5076    ;----- -- --      -- ---------- ---------
  5077   "RTN","DGO THRP2",9,0 )
  5078    ;10024 Su p       WA IT^DICD
  5079   "RTN","DGO THRP2",10, 0)
  5080    ;10063 Su p       $$ S^%ZTLOAD
  5081   "RTN","DGO THRP2",11, 0)
  5082    ;10086 Su p       HO ME^%ZIS
  5083   "RTN","DGO THRP2",12, 0)
  5084    ;10089 Su p       ^% ZISC
  5085   "RTN","DGO THRP2",13, 0)
  5086    ;10103 Su p       ^X LFDT: $$FM TE, $$NOW
  5087   "RTN","DGO THRP2",14, 0)
  5088    ;10112 Su p       $$ SITE^VASIT E
  5089   "RTN","DGO THRP2",15, 0)
  5090    ;10015/20 56 Sup   G ETS^DIQ
  5091   "RTN","DGO THRP2",16, 0)
  5092    ;10026 Su p       ^D IR
  5093   "RTN","DGO THRP2",17, 0)
  5094    ;6873  Co nt Sub  $$ OTHDCLCK^D GOTHD
  5095   "RTN","DGO THRP2",18, 0)
  5096    ;
  5097   "RTN","DGO THRP2",19, 0)
  5098    ;This rou tine will  be used to  display o r print Ot her Than H onorable 
  5099   "RTN","DGO THRP2",20, 0)
  5100    ;Active 9 0-Day Peri od Status
  5101   "RTN","DGO THRP2",21, 0)
  5102    ;
  5103   "RTN","DGO THRP2",22, 0)
  5104    ; INPUT:   DGSORT()  - see comm ents at th e top of r outine DGO THRPT for
  5105   "RTN","DGO THRP2",23, 0)
  5106    ;          explanati on of DGSO RT array
  5107   "RTN","DGO THRP2",24, 0)
  5108    ;
  5109   "RTN","DGO THRP2",25, 0)
  5110    ; Output:   A format ted report  of Other  Than Honor able 
  5111   "RTN","DGO THRP2",26, 0)
  5112    ;           Active 9 0-Day Peri od Status
  5113   "RTN","DGO THRP2",27, 0)
  5114    ;
  5115   "RTN","DGO THRP2",28, 0)
  5116    ;- no dir ect entry
  5117   "RTN","DGO THRP2",29, 0)
  5118    Q
  5119   "RTN","DGO THRP2",30, 0)
  5120    ;
  5121   "RTN","DGO THRP2",31, 0)
  5122   START ; co mpile and  print repo rt
  5123   "RTN","DGO THRP2",32, 0)
  5124    I $E(IOST )="C" D WA IT^DICD
  5125   "RTN","DGO THRP2",33, 0)
  5126    N HERE S  HERE=$$SIT E^VASITE ; extract th e IEN and  facility n ame
  5127   "RTN","DGO THRP2",34, 0)
  5128    N TRM S T RM=($E(IOS T)="C")
  5129   "RTN","DGO THRP2",35, 0)
  5130    N DGLIST  ;temp glob al name us ed for rep ort list
  5131   "RTN","DGO THRP2",36, 0)
  5132    S DGLIST= $NA(^TMP(" DGOTHR2",$ J))
  5133   "RTN","DGO THRP2",37, 0)
  5134    K @DGLIST
  5135   "RTN","DGO THRP2",38, 0)
  5136    D LOOP(.D GSORT,DGLI ST)
  5137   "RTN","DGO THRP2",39, 0)
  5138    D PRINT(. DGSORT,DGL IST)
  5139   "RTN","DGO THRP2",40, 0)
  5140    K @DGLIST
  5141   "RTN","DGO THRP2",41, 0)
  5142    W !!
  5143   "RTN","DGO THRP2",42, 0)
  5144    D EXIT
  5145   "RTN","DGO THRP2",43, 0)
  5146    Q
  5147   "RTN","DGO THRP2",44, 0)
  5148    ;
  5149   "RTN","DGO THRP2",45, 0)
  5150   LOOP(DGSOR T,DGLIST)  ;
  5151   "RTN","DGO THRP2",46, 0)
  5152    N DGDFN,D GDIEN,DGQ, DGRES,DGIE N,DGOLD,DG TOTAL
  5153   "RTN","DGO THRP2",47, 0)
  5154    ;loop var iable poin ter flag x -ref file  to run rep ort
  5155   "RTN","DGO THRP2",48, 0)
  5156    S (DGDFN, DGIEN,DGOL D)="",(DGT OTAL,DGQ)= 0
  5157   "RTN","DGO THRP2",49, 0)
  5158    F  S DGDF N=$O(^DGOT H(33,"B",D GDFN)) Q:D GDFN=""  D
  5159   "RTN","DGO THRP2",50, 0)
  5160    . N DGARR ,DGIEN33,D FN,DGRES,D GPTSTAT,DG 90A,DGERR, DGLS365D,D GLS365I
  5161   "RTN","DGO THRP2",51, 0)
  5162    . S DGRES =$$OTHDCLC K^DGOTHD(D GDFN,DT)
  5163   "RTN","DGO THRP2",52, 0)
  5164    . ;quit i f
  5165   "RTN","DGO THRP2",53, 0)
  5166    . ; - mis sing 365 o r 90 Day p eriod
  5167   "RTN","DGO THRP2",54, 0)
  5168    . ; - VBA  ADJUDICAT ION has be en COMPLET ED
  5169   "RTN","DGO THRP2",55, 0)
  5170    . ; - OTH D clock ha s been ina ctivated
  5171   "RTN","DGO THRP2",56, 0)
  5172    . ; - OTH ER THAN HO NORABLE el igibility  has been r emoved
  5173   "RTN","DGO THRP2",57, 0)
  5174    . Q:$P(DG RES,U)<1
  5175   "RTN","DGO THRP2",58, 0)
  5176    . S DGIEN 33=$O(^DGO TH(33,"B", DGDFN,0))
  5177   "RTN","DGO THRP2",59, 0)
  5178    . D GETS^ DIQ(33,DGI EN33_","," .01;.02;.0 3;1*","EI" ,"DGARR"," DGERR")
  5179   "RTN","DGO THRP2",60, 0)
  5180    . S DFN=$ G(DGARR(33 ,DGIEN33_" ,",.01,"I" ))
  5181   "RTN","DGO THRP2",61, 0)
  5182    . D CLOCK (DGIEN33)
  5183   "RTN","DGO THRP2",62, 0)
  5184    . I $P(DG SORT("DGST ATUS"),U)= 1 D ACTIVE (.DGSORT,D GLIST,DGRE S,DFN,DGIE N33,.DGARR ,.DG90A)
  5185   "RTN","DGO THRP2",63, 0)
  5186    Q
  5187   "RTN","DGO THRP2",64, 0)
  5188    ;
  5189   "RTN","DGO THRP2",65, 0)
  5190   CLOCK(DGIE N33) ;
  5191   "RTN","DGO THRP2",66, 0)
  5192    N DGN
  5193   "RTN","DGO THRP2",67, 0)
  5194    S DGLS365 D=+$O(^DGO TH(33,DGIE N33,1,"B", 999),-1)
  5195   "RTN","DGO THRP2",68, 0)
  5196    S DGLS365 I=+$O(^DGO TH(33,DGIE N33,1,"B", DGLS365D,0 ))
  5197   "RTN","DGO THRP2",69, 0)
  5198    S DGN=0 F   S DGN=+$ O(^DGOTH(3 3,DGIEN33, 1,DGLS365I ,1,"B",DGN )) Q:DGN=0   D
  5199   "RTN","DGO THRP2",70, 0)
  5200    . S DG90A (DGN)=+$O( ^DGOTH(33, DGIEN33,1, DGLS365I,1 ,"B",DGN,0 ))
  5201   "RTN","DGO THRP2",71, 0)
  5202    . S DGCLC K=DGN
  5203   "RTN","DGO THRP2",72, 0)
  5204    Q
  5205   "RTN","DGO THRP2",73, 0)
  5206    ;
  5207   "RTN","DGO THRP2",74, 0)
  5208   ACTIVE(DGS ORT,DGLIST ,DGRES,DFN ,DGIEN33,D GARR,DG90A ) ;
  5209   "RTN","DGO THRP2",75, 0)
  5210    N DGPTNM, DGSSN,DGAU TH,DGIENS, I,DGTMP,DG SSN,DGERR
  5211   "RTN","DGO THRP2",76, 0)
  5212    S DGPTNM= DGARR(33,D GIEN33_"," ,.01,"E")
  5213   "RTN","DGO THRP2",77, 0)
  5214    S DGSSN=$ $GET1^DIQ( 2,DFN_",", .0905,""," DGERR")
  5215   "RTN","DGO THRP2",78, 0)
  5216    ;
  5217   "RTN","DGO THRP2",79, 0)
  5218    I $D(DG90 A(1)) D
  5219   "RTN","DGO THRP2",80, 0)
  5220    . I $P(DG RES,U,5)>0 ,$$FIRST(D GRES) D
  5221   "RTN","DGO THRP2",81, 0)
  5222    . . S DGI ENS=DG90A( 1)_","_$P( DGRES,U)_" ,"_+DGIEN3 3_","
  5223   "RTN","DGO THRP2",82, 0)
  5224    . . S DGA UTH=$S($G( DGARR(33.1 1,DGIENS,. 07,"E"))=" ":"N/A",1: $G(DGARR(3 3.11,DGIEN S,.07,"E") ))
  5225   "RTN","DGO THRP2",83, 0)
  5226    . . S DGT MP=1_U_DGS SN_U_$$FMT E^XLFDT($P (DGRES,U,3 ),"5Z")_U_ $$FMTE^XLF DT($P(DGRE S,U,4),"5Z ")_U_$P(DG RES,U,5)_U _DGAUTH
  5227   "RTN","DGO THRP2",84, 0)
  5228    . . D SOR T(DGTMP,DG PTNM,1,DGR ES)
  5229   "RTN","DGO THRP2",85, 0)
  5230    I $D(DG90 A(2)) D
  5231   "RTN","DGO THRP2",86, 0)
  5232    . I $P(DG RES,U,8)>0 ,$$SECOND( DGRES) D
  5233   "RTN","DGO THRP2",87, 0)
  5234    . . S DGI ENS=DG90A( 2)_","_$P( DGRES,U)_" ,"_+DGIEN3 3_","
  5235   "RTN","DGO THRP2",88, 0)
  5236    . . S DGA UTH=$S($G( DGARR(33.1 1,DGIENS,. 07,"E"))=" ":"N/A",1: $G(DGARR(3 3.11,DGIEN S,.07,"E") ))
  5237   "RTN","DGO THRP2",89, 0)
  5238    . . S DGT MP=2_U_DGS SN_U_$$FMT E^XLFDT($P (DGRES,U,6 ),"5Z")_U_ $$FMTE^XLF DT($P(DGRE S,U,7),"5Z ")_U_$P(DG RES,U,8)_U _DGAUTH
  5239   "RTN","DGO THRP2",90, 0)
  5240    . . D SOR T(DGTMP,DG PTNM,2,DGR ES)
  5241   "RTN","DGO THRP2",91, 0)
  5242    Q
  5243   "RTN","DGO THRP2",92, 0)
  5244    ;
  5245   "RTN","DGO THRP2",93, 0)
  5246   SORT(DGTMP ,DGPTNM,DG CLCK,DGRES ) ;
  5247   "RTN","DGO THRP2",94, 0)
  5248    I $P(DGSO RT("DGSRTB Y"),U)=1 S  @DGLIST@( DGPTNM,DGC LCK)=DGTMP
  5249   "RTN","DGO THRP2",95, 0)
  5250    I $P(DGSO RT("DGSRTB Y"),U)=2 S  @DGLIST@( DGCLCK,DGP TNM)=DGTMP
  5251   "RTN","DGO THRP2",96, 0)
  5252    I $P(DGSO RT("DGSRTB Y"),U)=3 D
  5253   "RTN","DGO THRP2",97, 0)
  5254    . I DGCLC K=1 S @DGL IST@($P(DG RES,U,5),D GPTNM)=DGT MP
  5255   "RTN","DGO THRP2",98, 0)
  5256    . I DGCLC K=2 S @DGL IST@($P(DG RES,U,8),D GPTNM)=DGT MP
  5257   "RTN","DGO THRP2",99, 0)
  5258    I DGOLD'= DGPTNM S D GTOTAL=DGT OTAL+1,DGO LD=DGPTNM
  5259   "RTN","DGO THRP2",100 ,0)
  5260    I DGTOTAL >0 S @DGLI ST@("DGTOT AL")=DGTOT AL
  5261   "RTN","DGO THRP2",101 ,0)
  5262    Q
  5263   "RTN","DGO THRP2",102 ,0)
  5264    ;
  5265   "RTN","DGO THRP2",103 ,0)
  5266   FIRST(DGRE S) ;check  if dates f all within  the Begin  and End d ates
  5267   "RTN","DGO THRP2",104 ,0)
  5268    Q DGSORT( "DGBEG")<= $P(DGRES,U ,4)&(DGSOR T("DGEND") >=$P(DGRES ,U,4))
  5269   "RTN","DGO THRP2",105 ,0)
  5270    ;
  5271   "RTN","DGO THRP2",106 ,0)
  5272   SECOND(DGR ES) ;check  if dates  fall withi n the Begi n and End  dates
  5273   "RTN","DGO THRP2",107 ,0)
  5274    Q DGSORT( "DGBEG")<= $P(DGRES,U ,7)&(DGSOR T("DGEND") >=$P(DGRES ,U,7))
  5275   "RTN","DGO THRP2",108 ,0)
  5276    ;
  5277   "RTN","DGO THRP2",109 ,0)
  5278   PRINT(DGSO RT,DGLIST)  ;output r eport
  5279   "RTN","DGO THRP2",110 ,0)
  5280    N DGPAGE, DDASH,DGQ, DGSUB1,DGS UB2,DGSUB3 ,DGSTR,DGO LD,DGTOTAL
  5281   "RTN","DGO THRP2",111 ,0)
  5282    S (DGQ,DG PAGE,DGTOT AL)=0,$P(D DASH,"-",8 1)=""
  5283   "RTN","DGO THRP2",112 ,0)
  5284    S DGTOTAL =$G(@DGLIS T@("DGTOTA L"))
  5285   "RTN","DGO THRP2",113 ,0)
  5286    I $O(@DGL IST@(""))= "" D  Q
  5287   "RTN","DGO THRP2",114 ,0)
  5288    . D HEAD
  5289   "RTN","DGO THRP2",115 ,0)
  5290    . W !!,"  >>> No Rec ord were f ound using  the repor t criteria .",!
  5291   "RTN","DGO THRP2",116 ,0)
  5292    ;
  5293   "RTN","DGO THRP2",117 ,0)
  5294    ; loop an d print re port
  5295   "RTN","DGO THRP2",118 ,0)
  5296    S (DGSUB1 ,DGSUB2,DG SUB3,DGSTR ,DGOLD)=""
  5297   "RTN","DGO THRP2",119 ,0)
  5298    D HEAD
  5299   "RTN","DGO THRP2",120 ,0)
  5300    F  S DGSU B1=$O(@DGL IST@(DGSUB 1)) Q:DGSU B1=""  D   Q:DGQ
  5301   "RTN","DGO THRP2",121 ,0)
  5302    . F  S DG SUB2=$O(@D GLIST@(DGS UB1,DGSUB2 )) Q:DGSUB 2=""  D  Q :DGQ
  5303   "RTN","DGO THRP2",122 ,0)
  5304    . . S DGS TR=$G(@DGL IST@(DGSUB 1,DGSUB2))
  5305   "RTN","DGO THRP2",123 ,0)
  5306    . . W !
  5307   "RTN","DGO THRP2",124 ,0)
  5308    . . I $Y> (IOSL-4) D  PAUSE(.DG Q) Q:DGQ   D HEAD W !
  5309   "RTN","DGO THRP2",125 ,0)
  5310    . . I $P( DGSORT("DG SRTBY"),U) =1,DGSUB1' =DGOLD W $ E(DGSUB1,1 ,19),?21,$ P(DGSTR,U, 2) S DGOLD =DGSUB1
  5311   "RTN","DGO THRP2",126 ,0)
  5312    . . I $P( DGSORT("DG SRTBY"),U) =2!($P(DGS ORT("DGSRT BY"),U)=3) ,DGSUB2'=D GOLD W $E( DGSUB2,1,1 9),?21,$P( DGSTR,U,2)  S DGOLD=D GSUB2
  5313   "RTN","DGO THRP2",127 ,0)
  5314    . . W ?28 ,$P(DGSTR, U),?32,$P( DGSTR,U,3) ,?44,$P(DG STR,U,4),? 56,$P(DGST R,U,5),?62 ,$E($P(DGS TR,U,6),1, 15)
  5315   "RTN","DGO THRP2",128 ,0)
  5316    . Q:DGQ
  5317   "RTN","DGO THRP2",129 ,0)
  5318    W !!,"Tot al Active  OTH Patien ts from ", $$FMTE^XLF DT($G(DGSO RT("DGBEG" )),"5Z")
  5319   "RTN","DGO THRP2",130 ,0)
  5320    W " to ", $$FMTE^XLF DT($G(DGSO RT("DGEND" )),"5Z")," :",$J($S(D GTOTAL>0:D GTOTAL,1:0 ),6),!
  5321   "RTN","DGO THRP2",131 ,0)
  5322    Q
  5323   "RTN","DGO THRP2",132 ,0)
  5324    ;
  5325   "RTN","DGO THRP2",133 ,0)
  5326   HEAD ;Prin t/Display  Page Heade r
  5327   "RTN","DGO THRP2",134 ,0)
  5328    I $D(ZTQU EUED),$$S^ %ZTLOAD S  (ZTSTOP,DG Q)=1 Q
  5329   "RTN","DGO THRP2",135 ,0)
  5330    N DGFACLT Y
  5331   "RTN","DGO THRP2",136 ,0)
  5332    I TRM!('T RM&DGPAGE)  W @IOF
  5333   "RTN","DGO THRP2",137 ,0)
  5334    S DGPAGE= $G(DGPAGE) +1
  5335   "RTN","DGO THRP2",138 ,0)
  5336    S DGFACLT Y="Facilit y: "_$P(HE RE,U,2)
  5337   "RTN","DGO THRP2",139 ,0)
  5338    W ?71,"Pa ge:",?77,D GPAGE
  5339   "RTN","DGO THRP2",140 ,0)
  5340    W !,?80-$ L(ZTDESC)\ 2,$G(ZTDES C),!,?80-$ L(DGFACLTY )\2,DGFACL TY
  5341   "RTN","DGO THRP2",141 ,0)
  5342    W !,"Date  Range:",? 12,$$FMTE^ XLFDT(DGSO RT("DGBEG" ),"5Z")_"  TO "_$$FMT E^XLFDT(DG SORT("DGEN D"),"5Z")
  5343   "RTN","DGO THRP2",142 ,0)
  5344    W ?48,"So rted By:", ?59,$E($P( $G(DGSORT( "DGSRTBY") ),U,2),9,$ L($P($G(DG SORT("DGSR TBY")),U,2 )))
  5345   "RTN","DGO THRP2",143 ,0)
  5346    W !,"Stat us    :",? 12,$P($G(D GSORT("DGS TATUS")),U ,2)
  5347   "RTN","DGO THRP2",144 ,0)
  5348    W ?48,"Pr inted  :", ?59,$$FMTE ^XLFDT($$N OW^XLFDT," MP")
  5349   "RTN","DGO THRP2",145 ,0)
  5350    W !,DDASH
  5351   "RTN","DGO THRP2",146 ,0)
  5352    W !,"PATI ENT NAME", ?21,"PID", ?27,"PRD", ?32,"START  DATE",?44 ,"END DATE ",?56,"DAY S",?62,"AU THORIZED B Y"
  5353   "RTN","DGO THRP2",147 ,0)
  5354    W !,?56," LEFT"
  5355   "RTN","DGO THRP2",148 ,0)
  5356    W !,DDASH
  5357   "RTN","DGO THRP2",149 ,0)
  5358    Q
  5359   "RTN","DGO THRP2",150 ,0)
  5360    ;
  5361   "RTN","DGO THRP2",151 ,0)
  5362   PAUSE(DGQ)  ; pause s creen disp lay
  5363   "RTN","DGO THRP2",152 ,0)
  5364    ; Input: 
  5365   "RTN","DGO THRP2",153 ,0)
  5366    ; DGQ - v ar used to  quit repo rt process ing to use r CRT
  5367   "RTN","DGO THRP2",154 ,0)
  5368    ; Output:
  5369   "RTN","DGO THRP2",155 ,0)
  5370    ; DGQ - p assed by r eference -  0 = Conti nue, 1 = Q uit
  5371   "RTN","DGO THRP2",156 ,0)
  5372    ;
  5373   "RTN","DGO THRP2",157 ,0)
  5374    I $G(DGPA GE)>0,TRM  K DIR S DI R(0)="E" D  ^DIR K DI R S:+Y=0 D GQ=1
  5375   "RTN","DGO THRP2",158 ,0)
  5376    Q
  5377   "RTN","DGO THRP2",159 ,0)
  5378    ;
  5379   "RTN","DGO THRP2",160 ,0)
  5380   EXIT ;
  5381   "RTN","DGO THRP2",161 ,0)
  5382    I $D(ZTQU EUED) S ZT REQ="@"  ; tell TaskM an to dele te Task lo g entry
  5383   "RTN","DGO THRP2",162 ,0)
  5384    I '$D(ZTQ UEUED) D
  5385   "RTN","DGO THRP2",163 ,0)
  5386    . I 'TRM, $Y>0 W @IO F
  5387   "RTN","DGO THRP2",164 ,0)
  5388    . K %ZIS, POP
  5389   "RTN","DGO THRP2",165 ,0)
  5390    . D ^%ZIS C,HOME^%ZI S
  5391   "RTN","DGO THRP2",166 ,0)
  5392    Q
  5393   "RTN","DGO THRP3")
  5394   0^11^B1997 17857
  5395   "RTN","DGO THRP3",1,0 )
  5396   DGOTHRP3 ; SLC/RM - O TH PATIENT  PERIOD ST ATUS REPOR T CONT. ;M AY 8, 2018 @5:15
  5397   "RTN","DGO THRP3",2,0 )
  5398    ;;5.3;Reg istration; **952**;Au g 13, 1993 ;Build 68
  5399   "RTN","DGO THRP3",3,0 )
  5400    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  5401   "RTN","DGO THRP3",4,0 )
  5402    ;
  5403   "RTN","DGO THRP3",5,0 )
  5404    ;     Las t Edited:  SHRPE/RM -  MAY 8, 20 18 17:15
  5405   "RTN","DGO THRP3",6,0 )
  5406    ;
  5407   "RTN","DGO THRP3",7,0 )
  5408    ; ICR# TY PE      DE SCRIPTION
  5409   "RTN","DGO THRP3",8,0 )
  5410    ;----- -- --      -- ---------- ---------
  5411   "RTN","DGO THRP3",9,0 )
  5412    ;10024 Su p       WA IT^DICD
  5413   "RTN","DGO THRP3",10, 0)
  5414    ;10063 Su p       $$ S^%ZTLOAD
  5415   "RTN","DGO THRP3",11, 0)
  5416    ;10086 Su p       HO ME^%ZIS
  5417   "RTN","DGO THRP3",12, 0)
  5418    ;10089 Su p       ^% ZISC
  5419   "RTN","DGO THRP3",13, 0)
  5420    ;10103 Su p       ^X LFDT: $$FM TE, $$NOW
  5421   "RTN","DGO THRP3",14, 0)
  5422    ;10112 Su p       $$ SITE^VASIT E
  5423   "RTN","DGO THRP3",15, 0)
  5424    ;10015 Su p       GE TS^DIQ
  5425   "RTN","DGO THRP3",16, 0)
  5426    ;10026 Su p       ^D IR
  5427   "RTN","DGO THRP3",17, 0)
  5428    ;6873  Co nt Sub  $$ OTHDCLCK^D GOTHD
  5429   "RTN","DGO THRP3",18, 0)
  5430    ;
  5431   "RTN","DGO THRP3",19, 0)
  5432    ;This rou tine will  be used to  display o r print Ot her Than H onorable 
  5433   "RTN","DGO THRP3",20, 0)
  5434    ;patient  treated un der OTH au thority.
  5435   "RTN","DGO THRP3",21, 0)
  5436    ;
  5437   "RTN","DGO THRP3",22, 0)
  5438    ; INPUT:   DGSORT()  - see comm ents at th e top of r outine DGO THRPT for
  5439   "RTN","DGO THRP3",23, 0)
  5440    ;          explanati on of DGSO RT array
  5441   "RTN","DGO THRP3",24, 0)
  5442    ;
  5443   "RTN","DGO THRP3",25, 0)
  5444    ; Output:   A format ted report  of Other  Than Honor able Stati stical Rep ort
  5445   "RTN","DGO THRP3",26, 0)
  5446    ;
  5447   "RTN","DGO THRP3",27, 0)
  5448    ;- no dir ect entry
  5449   "RTN","DGO THRP3",28, 0)
  5450    Q
  5451   "RTN","DGO THRP3",29, 0)
  5452    ;
  5453   "RTN","DGO THRP3",30, 0)
  5454   START ; co mpile and  print repo rt
  5455   "RTN","DGO THRP3",31, 0)
  5456    I $E(IOST )="C" D WA IT^DICD
  5457   "RTN","DGO THRP3",32, 0)
  5458    N HERE S  HERE=$$SIT E^VASITE ; extract th e IEN and  facility n ame
  5459   "RTN","DGO THRP3",33, 0)
  5460    N TRM S T RM=($E(IOS T)="C")
  5461   "RTN","DGO THRP3",34, 0)
  5462    N DGLIST  ;temp glob al name us ed for rep ort list
  5463   "RTN","DGO THRP3",35, 0)
  5464    N DGQRT    ;array or  report pa rameters f or quarter s
  5465   "RTN","DGO THRP3",36, 0)
  5466    S DGLIST= $NA(^TMP(" DGOTHST",$ J))
  5467   "RTN","DGO THRP3",37, 0)
  5468    N DGCNT,D GNET
  5469   "RTN","DGO THRP3",38, 0)
  5470    K @DGLIST
  5471   "RTN","DGO THRP3",39, 0)
  5472    S (DGCNT, DGNET)=0
  5473   "RTN","DGO THRP3",40, 0)
  5474    D LOOP(.D GSORT,DGLI ST)
  5475   "RTN","DGO THRP3",41, 0)
  5476    D PRINT1( .DGSORT,DG LIST,.DGCN T) ;by mon th or all  month in t he quarter s
  5477   "RTN","DGO THRP3",42, 0)
  5478    K @DGLIST
  5479   "RTN","DGO THRP3",43, 0)
  5480    W !
  5481   "RTN","DGO THRP3",44, 0)
  5482    D EXIT^DG OTHRP2
  5483   "RTN","DGO THRP3",45, 0)
  5484    Q
  5485   "RTN","DGO THRP3",46, 0)
  5486    ;
  5487   "RTN","DGO THRP3",47, 0)
  5488   LOOP(DGSOR T,DGLIST)  ;
  5489   "RTN","DGO THRP3",48, 0)
  5490    I 123[$P( DGSORT("DG MON"),U) D  LOOP2(.DG SORT,DGLIS T) Q  ;by  month
  5491   "RTN","DGO THRP3",49, 0)
  5492    I 4[$P(DG SORT("DGMO N"),U) D L OOP1(.DGSO RT,DGLIST)  Q  ;all m onth in th e quarter
  5493   "RTN","DGO THRP3",50, 0)
  5494    I 5[$P(DG SORT("DGMO N"),U) D L OOP3(.DGSO RT,DGLIST)   ;fiscal  year
  5495   "RTN","DGO THRP3",51, 0)
  5496    Q
  5497   "RTN","DGO THRP3",52, 0)
  5498    ;
  5499   "RTN","DGO THRP3",53, 0)
  5500   LOOP1(DGSO RT,DGLIST)  ;
  5501   "RTN","DGO THRP3",54, 0)
  5502    ; If 4[$P (DGSORT("D GMON"),U)
  5503   "RTN","DGO THRP3",55, 0)
  5504    ;    - Th en, build  DGSORT("DG BEG") and  DGSORT("DG END") 
  5505   "RTN","DGO THRP3",56, 0)
  5506    ;      fo r each mon th on the  fly
  5507   "RTN","DGO THRP3",57, 0)
  5508    N DGMON,I I
  5509   "RTN","DGO THRP3",58, 0)
  5510    S II="" F   S II=$O( DGSORT("DG MON",II))  Q:II=""  D
  5511   "RTN","DGO THRP3",59, 0)
  5512    . S DGMON =$$CALRNGE ^DGOTHRPT( .DGSORT,"" ,II)
  5513   "RTN","DGO THRP3",60, 0)
  5514    . S DGSOR T("DGBEG") =$P(DGMON, U)
  5515   "RTN","DGO THRP3",61, 0)
  5516    . S DGSOR T("DGEND") =$P(DGMON, U,2)
  5517   "RTN","DGO THRP3",62, 0)
  5518    . D LOOP2 (.DGSORT,D GLIST)
  5519   "RTN","DGO THRP3",63, 0)
  5520    Q
  5521   "RTN","DGO THRP3",64, 0)
  5522    ;
  5523   "RTN","DGO THRP3",65, 0)
  5524   LOOP2(DGSO RT,DGLIST)  ;
  5525   "RTN","DGO THRP3",66, 0)
  5526    N DGDFN,D GDIEN,DGQ, DGRES,DGIE N,DGOLD,DG QNUM
  5527   "RTN","DGO THRP3",67, 0)
  5528    ;loop var iable poin ter flag x -ref file  to run rep ort
  5529   "RTN","DGO THRP3",68, 0)
  5530    S (DGDFN, DGIEN,DGOL D)="",DGQ= 0
  5531   "RTN","DGO THRP3",69, 0)
  5532    F  S DGDF N=$O(^DGOT H(33,"B",D GDFN)) Q:D GDFN=""  D
  5533   "RTN","DGO THRP3",70, 0)
  5534    . N DGARR ,DGIEN33,D FN,DGRES,D GPTSTAT,DG 90A,DGOSTA T
  5535   "RTN","DGO THRP3",71, 0)
  5536    . S DGIEN 33=$O(^DGO TH(33,"B", DGDFN,0)), (DGRES,DGO STAT)=0
  5537   "RTN","DGO THRP3",72, 0)
  5538    . D CLOCK ^DGOTHRP2( DGIEN33)
  5539   "RTN","DGO THRP3",73, 0)
  5540    . Q:'$D(D G90A)  ;no  90 days p eriods for  the 365 d ays period
  5541   "RTN","DGO THRP3",74, 0)
  5542    . Q:'$D(D G90A(1))   ;missing t he 1st 90  days perio d for the  365 days p eriod
  5543   "RTN","DGO THRP3",75, 0)
  5544    . D GETS^ DIQ(33,DGI EN33_","," .01;.02;.0 3;.06;.07; .08;.09;1* ","EI","DG ARR","DGER R")
  5545   "RTN","DGO THRP3",76, 0)
  5546    . S DGRES =$$RESULT( .DGARR,.DG 90A,DGIEN3 3)
  5547   "RTN","DGO THRP3",77, 0)
  5548    . S DGRES =$$INEXRPT (DGRES,.DG SORT,.DG90 A)
  5549   "RTN","DGO THRP3",78, 0)
  5550    . Q:DGRES <1
  5551   "RTN","DGO THRP3",79, 0)
  5552    . S DFN=$ G(DGARR(33 ,DGIEN33_" ,",.01,"I" ))
  5553   "RTN","DGO THRP3",80, 0)
  5554    . D SORT( .DGSORT,DG LIST,DGRES ,DFN,DGIEN 33,.DGARR, .DG90A)
  5555   "RTN","DGO THRP3",81, 0)
  5556    Q
  5557   "RTN","DGO THRP3",82, 0)
  5558    ;
  5559   "RTN","DGO THRP3",83, 0)
  5560   LOOP3(DGSO RT,DGLIST)  ;Fiscal y ear detail
  5561   "RTN","DGO THRP3",84, 0)
  5562    ; If 5[$P (DGSORT("D GMON"),U)
  5563   "RTN","DGO THRP3",85, 0)
  5564    ;    - Th en, build  DGSORT("DG BEG") and  DGSORT("DG END") 
  5565   "RTN","DGO THRP3",86, 0)
  5566    ;      fo r each mon th in the  quarter on  the fly
  5567   "RTN","DGO THRP3",87, 0)
  5568    N DGMON,D GQRTR,M,Q
  5569   "RTN","DGO THRP3",88, 0)
  5570    S Q="" F   S Q=$O(DG SORT("DGMO N",Q)) Q:Q =""  D
  5571   "RTN","DGO THRP3",89, 0)
  5572    . S M=""  F  S M=$O( DGSORT("DG MON",Q,M))  Q:M=""  D
  5573   "RTN","DGO THRP3",90, 0)
  5574    . . S DGM ON=$$CALRN GE^DGOTHRP T(.DGSORT, Q,M)
  5575   "RTN","DGO THRP3",91, 0)
  5576    . . S DGS ORT("DGBEG ")=$P(DGMO N,U)
  5577   "RTN","DGO THRP3",92, 0)
  5578    . . S DGS ORT("DGEND ")=$P(DGMO N,U,2)
  5579   "RTN","DGO THRP3",93, 0)
  5580    . . S DGQ RTR=Q
  5581   "RTN","DGO THRP3",94, 0)
  5582    . . D LOO P2(.DGSORT ,DGLIST)
  5583   "RTN","DGO THRP3",95, 0)
  5584    Q
  5585   "RTN","DGO THRP3",96, 0)
  5586    ;
  5587   "RTN","DGO THRP3",97, 0)
  5588   RESULT(DGA RR,DG90A,D GIEN33) ;g et the res ult for OT H patient
  5589   "RTN","DGO THRP3",98, 0)
  5590    ;
  5591   "RTN","DGO THRP3",99, 0)
  5592    N DGIENS, DGDATE,DGP 1,I,II
  5593   "RTN","DGO THRP3",100 ,0)
  5594    S DGRES=" "
  5595   "RTN","DGO THRP3",101 ,0)
  5596    S DGDATE= $S($G(DGDA TE)>0:DGDA TE,1:DT)
  5597   "RTN","DGO THRP3",102 ,0)
  5598    F I=1:1:D GLS365D D
  5599   "RTN","DGO THRP3",103 ,0)
  5600    . S DGRET (I)=""
  5601   "RTN","DGO THRP3",104 ,0)
  5602    . F II=1: 1:DGCLCK D
  5603   "RTN","DGO THRP3",105 ,0)
  5604    . . N DGS DT,DGENDT, DGDIFF
  5605   "RTN","DGO THRP3",106 ,0)
  5606    . . S DGI ENS=DG90A( II)_","_+D GLS365I_", "_+DGIEN33 _","
  5607   "RTN","DGO THRP3",107 ,0)
  5608    . . S DGS DT=DGARR(3 3.11,DGIEN S,.02,"I")  ;start da te
  5609   "RTN","DGO THRP3",108 ,0)
  5610    . . S DGE NDT=$$FMAD D^XLFDT(DG SDT,90) ;e nd date
  5611   "RTN","DGO THRP3",109 ,0)
  5612    . . ;days  remaining
  5613   "RTN","DGO THRP3",110 ,0)
  5614    . . S DGD IFF=$S(DGD ATE<DGSDT: $$FMDIFF^X LFDT(DGEND T,DGSDT,1) ,DGDATE=DG SDT!(DGDAT E>DGSDT):$ $FMDIFF^XL FDT(DGENDT ,DGDATE,1) ,1:0)
  5615   "RTN","DGO THRP3",111 ,0)
  5616    . . I DGD IFF<0 S DG DIFF=0
  5617   "RTN","DGO THRP3",112 ,0)
  5618    . . S DGR ES=DGRES_D GSDT_U_DGE NDT_U_DGDI FF_U
  5619   "RTN","DGO THRP3",113 ,0)
  5620    . . S DGR ET(I,II)=D GSDT_U_DGE NDT_U_DGDI FF
  5621   "RTN","DGO THRP3",114 ,0)
  5622    . . ;dete rmine whic h clock is  considere d "active"  within th e current  365-Day pe riod
  5623   "RTN","DGO THRP3",115 ,0)
  5624    . . I DGD IFF>0,DGDI FF<90 S DG RET(I)=II
  5625   "RTN","DGO THRP3",116 ,0)
  5626    Q DGRES
  5627   "RTN","DGO THRP3",117 ,0)
  5628    ;
  5629   "RTN","DGO THRP3",118 ,0)
  5630   INEXRPT(DG RES,DGSORT ,DG90A) ;
  5631   "RTN","DGO THRP3",119 ,0)
  5632    ;check if  OTH Patie nt will be  included  or
  5633   "RTN","DGO THRP3",120 ,0)
  5634    ;excluded  into the  statistica l report
  5635   "RTN","DGO THRP3",121 ,0)
  5636    N DGPTST, DGINDT,DGP RD1,DGPRD2 ,DG5,DGP8, DGOK1,DGOK 2
  5637   "RTN","DGO THRP3",122 ,0)
  5638    S (DGPTST ,DGPRD1,DG PRD2,DGIND T,DGP8,DGO K1,DGOK2)= 0
  5639   "RTN","DGO THRP3",123 ,0)
  5640    I $D(DG90 A(1)),$$PO CDT(DGRES, .DGSORT,3, 4) S DGPRD 1=1 ;withi n or equal  to the da te range s pecified b y the user
  5641   "RTN","DGO THRP3",124 ,0)
  5642    I $D(DG90 A(2)),$$PO CDT(DGRES, .DGSORT,6, 7) S DGPRD 2=1 ;withi n or equal  to the da te range s pecified b y the user
  5643   "RTN","DGO THRP3",125 ,0)
  5644    I 'DGPRD1 ,'DGPRD2 Q  0
  5645   "RTN","DGO THRP3",126 ,0)
  5646    ; 1 = Act ive
  5647   "RTN","DGO THRP3",127 ,0)
  5648    ; 2 = Adj udicated
  5649   "RTN","DGO THRP3",128 ,0)
  5650    ; 3 = Ina ctivated w /o adjudic ation
  5651   "RTN","DGO THRP3",129 ,0)
  5652    S DGPTST= $$STATUS^D GOTHRI(.DG ARR) ;OTH  patient cl ock status
  5653   "RTN","DGO THRP3",130 ,0)
  5654    ;get the  inactivati on date if  there is  one
  5655   "RTN","DGO THRP3",131 ,0)
  5656    I 23[DGPT ST D
  5657   "RTN","DGO THRP3",132 ,0)
  5658    . S DGIND T=$G(DGARR (33,DGIEN3 3_",",.06, "I")) ;mea ns patient  received  adjudicati on
  5659   "RTN","DGO THRP3",133 ,0)
  5660    . I DGIND T="" S DGI NDT=$G(DGA RR(33,DGIE N33_",",.0 8,"I")) ;m eans patie nt get ina ctivated w ithout adj udication
  5661   "RTN","DGO THRP3",134 ,0)
  5662    ;compare  the beg an d end date  of the 90 -day perio d of care  to the ina ctivation  date.
  5663   "RTN","DGO THRP3",135 ,0)
  5664    ;if inact ivation da te is with in or equa l to the b eg and end  date of t he 90-day  period of  care
  5665   "RTN","DGO THRP3",136 ,0)
  5666    ;include  the patien t into the  statistic al report
  5667   "RTN","DGO THRP3",137 ,0)
  5668    I DGPRD1  D
  5669   "RTN","DGO THRP3",138 ,0)
  5670    . I 23[DG PTST D
  5671   "RTN","DGO THRP3",139 ,0)
  5672    . . I (DG INDT>=$P(D GRES,U,3)) &(DGINDT<= $P(DGRES,U ,4))&($$CH KINDT) S D GOK1=1
  5673   "RTN","DGO THRP3",140 ,0)
  5674    . . I (DG INDT>$P(DG RES,U,4))& (DGINDT<$P (DGRES,U,6 ))&($$CHKI NDT) S DGO K1=1
  5675   "RTN","DGO THRP3",141 ,0)
  5676    . . I DGI NDT>=$P(DG RES,U,6)&( $$CHKINDT)  S DGOK1=1
  5677   "RTN","DGO THRP3",142 ,0)
  5678    . I 1[DGP TST S DGOK 1=1
  5679   "RTN","DGO THRP3",143 ,0)
  5680    ;
  5681   "RTN","DGO THRP3",144 ,0)
  5682    I DGPRD2  D
  5683   "RTN","DGO THRP3",145 ,0)
  5684    . I 23[DG PTST D
  5685   "RTN","DGO THRP3",146 ,0)
  5686    . . I DGI NDT>=$P(DG RES,U,6)&( $$CHKINDT)  S DGOK2=1
  5687   "RTN","DGO THRP3",147 ,0)
  5688    . I 1[DGP TST S DGOK 2=1
  5689   "RTN","DGO THRP3",148 ,0)
  5690    S DGRES=D GRES_U_DGI NDT_U_DGOK 1_U_DGOK2
  5691   "RTN","DGO THRP3",149 ,0)
  5692    Q DGRES
  5693   "RTN","DGO THRP3",150 ,0)
  5694    ;
  5695   "RTN","DGO THRP3",151 ,0)
  5696   CHKINDT()  ;
  5697   "RTN","DGO THRP3",152 ,0)
  5698    ;check th e inactiva tion date  if it fall s within t he date ra nge.
  5699   "RTN","DGO THRP3",153 ,0)
  5700    ;If not,  do not dis play the O TH Patient  name.
  5701   "RTN","DGO THRP3",154 ,0)
  5702    I (DGINDT >=(DGSORT( "DGBEG")))  Q 1
  5703   "RTN","DGO THRP3",155 ,0)
  5704    Q 0
  5705   "RTN","DGO THRP3",156 ,0)
  5706    ;
  5707   "RTN","DGO THRP3",157 ,0)
  5708   POCDT(DGRE S,DGSORT,D GP1,DGP2)  ;
  5709   "RTN","DGO THRP3",158 ,0)
  5710    ;check if  period of  care date s fall wit hin the da te range s pecified b y the user
  5711   "RTN","DGO THRP3",159 ,0)
  5712    N OK
  5713   "RTN","DGO THRP3",160 ,0)
  5714    S OK=0
  5715   "RTN","DGO THRP3",161 ,0)
  5716    S:$P(DGRE S,U,DGP1)> =(DGSORT(" DGBEG"))&( $P(DGRES,U ,DGP1)<=(D GSORT("DGE ND"))) OK= 1
  5717   "RTN","DGO THRP3",162 ,0)
  5718    S:$P(DGRE S,U,DGP2)> =(DGSORT(" DGBEG"))&( $P(DGRES,U ,DGP2)<=(D GSORT("DGE ND"))) OK= 1
  5719   "RTN","DGO THRP3",163 ,0)
  5720    S:$P(DGRE S,U,DGP1)< =(DGSORT(" DGEND"))&( $P(DGRES,U ,DGP2)>=(D GSORT("DGE ND"))) OK= 1
  5721   "RTN","DGO THRP3",164 ,0)
  5722    Q OK
  5723   "RTN","DGO THRP3",165 ,0)
  5724    ;
  5725   "RTN","DGO THRP3",166 ,0)
  5726   SORT(DGSOR T,DGLIST,D GRES,DFN,D GIEN33,DGA RR,DG90A)  ;
  5727   "RTN","DGO THRP3",167 ,0)
  5728    N DGPTNM, DGSSN,DGAU TH,DGIENS, I,DGTMP,DG SSN,DGSTAT ,DGVBA,DGM ON,DGERR
  5729   "RTN","DGO THRP3",168 ,0)
  5730    S DGPTNM= DGARR(33,D GIEN33_"," ,.01,"E")
  5731   "RTN","DGO THRP3",169 ,0)
  5732    S DGSSN=$ $GET1^DIQ( 2,DFN_",", .0905,""," DGERR")
  5733   "RTN","DGO THRP3",170 ,0)
  5734    ;
  5735   "RTN","DGO THRP3",171 ,0)
  5736    ;DGRES $P ^10:
  5737   "RTN","DGO THRP3",172 ,0)
  5738    ; 0  - in dicates pa tient is a ctive
  5739   "RTN","DGO THRP3",173 ,0)
  5740    ; >0 - in dicates pa tient has  been inact ivated (wi ll contain  FM date)
  5741   "RTN","DGO THRP3",174 ,0)
  5742    ;DGRES $P ^11 and $P ^12 :
  5743   "RTN","DGO THRP3",175 ,0)
  5744    ; 1 indic ates to di splay the  1st/2nd 90 -Day POC
  5745   "RTN","DGO THRP3",176 ,0)
  5746    ; 0 not d isplay
  5747   "RTN","DGO THRP3",177 ,0)
  5748    I $P(DGRE S,U,11) D
  5749   "RTN","DGO THRP3",178 ,0)
  5750    . S DGIEN S=DG90A(1) _","_$P(DG RES,U)_"," _+DGIEN33_ ","
  5751   "RTN","DGO THRP3",179 ,0)
  5752    . S DGAUT H=$S($G(DG ARR(33.11, DGIENS,.07 ,"E"))="": "N/A",1:$G (DGARR(33. 11,DGIENS, .07,"E")))
  5753   "RTN","DGO THRP3",180 ,0)
  5754    . S DGTMP =1_U_DGSSN _U_$$FMTE^ XLFDT($P(D GRES,U,3), "5Z")_U_$$ FMTE^XLFDT ($P(DGRES, U,4),"5Z") _U_$P(DGRE S,U,5)_U_D GAUTH
  5755   "RTN","DGO THRP3",181 ,0)
  5756    . S DGTMP =DGTMP_U_$ S($P(DGRES ,U,10)>0:$ $FMTE^XLFD T($P(DGRES ,U,10),"5Z "),1:"")
  5757   "RTN","DGO THRP3",182 ,0)
  5758    . D BLD(D GTMP,DGPTN M,$P(DGRES ,U,3),.DGS ORT,1,DFN)  ;display  the 1st 90 -Day
  5759   "RTN","DGO THRP3",183 ,0)
  5760    ;
  5761   "RTN","DGO THRP3",184 ,0)
  5762    I $P(DGRE S,U,12) D
  5763   "RTN","DGO THRP3",185 ,0)
  5764    . S DGIEN S=DG90A(2) _","_$P(DG RES,U)_"," _+DGIEN33_ ","
  5765   "RTN","DGO THRP3",186 ,0)
  5766    . S DGAUT H=$S($G(DG ARR(33.11, DGIENS,.07 ,"E"))="": "N/A",1:$G (DGARR(33. 11,DGIENS, .07,"E")))
  5767   "RTN","DGO THRP3",187 ,0)
  5768    . S DGTMP =2_U_DGSSN _U_$$FMTE^ XLFDT($P(D GRES,U,6), "5Z")_U_$$ FMTE^XLFDT ($P(DGRES, U,7),"5Z") _U_$P(DGRE S,U,8)_U_D GAUTH
  5769   "RTN","DGO THRP3",188 ,0)
  5770    . S DGTMP =DGTMP_U_$ S($P(DGRES ,U,10)>0:$ $FMTE^XLFD T($P(DGRES ,U,10),"5Z "),1:"")
  5771   "RTN","DGO THRP3",189 ,0)
  5772    . D BLD(D GTMP,DGPTN M,$P(DGRES ,U,6),.DGS ORT,2,DFN)  ;display  the 2nd 90 -Day
  5773   "RTN","DGO THRP3",190 ,0)
  5774    Q
  5775   "RTN","DGO THRP3",191 ,0)
  5776    ;
  5777   "RTN","DGO THRP3",192 ,0)
  5778   BLD(DGTMP, DGPTNM,DGS TDT,DGSORT ,DGCLCK,DF N) ;
  5779   "RTN","DGO THRP3",193 ,0)
  5780    D MONCNT( .DGSORT,DG TMP,DGPTNM ,DGSTDT,DG CLCK,DFN)
  5781   "RTN","DGO THRP3",194 ,0)
  5782    Q
  5783   "RTN","DGO THRP3",195 ,0)
  5784    ;
  5785   "RTN","DGO THRP3",196 ,0)
  5786   MONCNT(DGS ORT,DGTMP, DGPTNM,DGS TDT,DGCLCK ,DFN) ;
  5787   "RTN","DGO THRP3",197 ,0)
  5788    ;build an d count th e new and  old oth pa tients by  monthly
  5789   "RTN","DGO THRP3",198 ,0)
  5790    N DGMON,D GVASSN
  5791   "RTN","DGO THRP3",199 ,0)
  5792    S DGMON=+ $E(DGSTDT, 4,5)
  5793   "RTN","DGO THRP3",200 ,0)
  5794    I DGSORT( "DGBEG")<= DGSTDT,(DG SORT("DGEN D"))>=DGST DT D
  5795   "RTN","DGO THRP3",201 ,0)
  5796    . D BLDNE W(DGPTNM,D GMON,DGCLC K,DGTMP)
  5797   "RTN","DGO THRP3",202 ,0)
  5798    . S DGCNT ("NEW")=$G (DGCNT("NE W"))+1
  5799   "RTN","DGO THRP3",203 ,0)
  5800    . I 45[$P (DGSORT("D GMON"),U)  S DGCNT("N EW",DGMON) =$G(DGCNT( "NEW",DGMO N))+1
  5801   "RTN","DGO THRP3",204 ,0)
  5802    E  D
  5803   "RTN","DGO THRP3",205 ,0)
  5804    . I $P(DG RES,U,11), $P(DGRES,U ,12) D BLD NEW(DGPTNM ,+$E($P(DG RES,U,4),4 ,5),DGCLCK ,DGTMP) Q
  5805   "RTN","DGO THRP3",206 ,0)
  5806    . D BLDOL D(DGPTNM,D GMON,DGCLC K,DGTMP)
  5807   "RTN","DGO THRP3",207 ,0)
  5808    . S DGCNT ("OLD")=$G (DGCNT("OL D"))+1
  5809   "RTN","DGO THRP3",208 ,0)
  5810    . I 45[$P (DGSORT("D GMON"),U)  D
  5811   "RTN","DGO THRP3",209 ,0)
  5812    . . I DGC LCK=1 S DG MON=+$E($P (DGRES,U,4 ),4,5)
  5813   "RTN","DGO THRP3",210 ,0)
  5814    . . I DGC LCK=2 S DG MON=+$E($P (DGRES,U,7 ),4,5)
  5815   "RTN","DGO THRP3",211 ,0)
  5816    . . S DGC NT("OLD",+ $E(DGSORT( "DGBEG"),4 ,5))=$G(DG CNT("OLD", +$E(DGSORT ("DGBEG"), 4,5)))+1
  5817   "RTN","DGO THRP3",212 ,0)
  5818    S DGCNT=$ G(DGCNT("N EW"))+$G(D GCNT("OLD" ))
  5819   "RTN","DGO THRP3",213 ,0)
  5820    I 5[$P(DG SORT("DGMO N"),U) D 
  5821   "RTN","DGO THRP3",214 ,0)
  5822    . D DEM^V ADPT
  5823   "RTN","DGO THRP3",215 ,0)
  5824    . I '$D(D GNET($P(VA DM(2),U),D GPTNM)) D
  5825   "RTN","DGO THRP3",216 ,0)
  5826    . . S DGN ET($P(VADM (2),U),DGP TNM)=""
  5827   "RTN","DGO THRP3",217 ,0)
  5828    . . S DGN ET=DGNET+1
  5829   "RTN","DGO THRP3",218 ,0)
  5830    Q
  5831   "RTN","DGO THRP3",219 ,0)
  5832    ;
  5833   "RTN","DGO THRP3",220 ,0)
  5834   BLDNEW(DGP TNM,DGMON, DGCLCK,DGT MP) ;
  5835   "RTN","DGO THRP3",221 ,0)
  5836    S @DGLIST @("NEW",$S (1234[$P(D GSORT("DGM ON"),U):$P (DGSORT("D GQTR"),U), 1:DGQRTR), DGMON,DGPT NM,DGCLCK) =DGTMP
  5837   "RTN","DGO THRP3",222 ,0)
  5838    Q
  5839   "RTN","DGO THRP3",223 ,0)
  5840    ;
  5841   "RTN","DGO THRP3",224 ,0)
  5842   BLDOLD(DGP TNM,DGMON, DGCLCK,DGT MP) ;
  5843   "RTN","DGO THRP3",225 ,0)
  5844    I DGCLCK= 1 S DGMON= +$E($P(DGR ES,U,4),4, 5)
  5845   "RTN","DGO THRP3",226 ,0)
  5846    I DGCLCK= 2 S DGMON= +$E($P(DGR ES,U,7),4, 5)
  5847   "RTN","DGO THRP3",227 ,0)
  5848    S @DGLIST @("OLD",$S (1234[$P(D GSORT("DGM ON"),U):$P (DGSORT("D GQTR"),U), 1:DGQRTR), +$E(DGSORT ("DGBEG"), 4,5),DGPTN M,DGCLCK)= DGTMP
  5849   "RTN","DGO THRP3",228 ,0)
  5850    Q
  5851   "RTN","DGO THRP3",229 ,0)
  5852    ;
  5853   "RTN","DGO THRP3",230 ,0)
  5854   PRINT1(DGS ORT,DGLIST ,DGCNT) ;d isplay by  month or m onth in th e quarter
  5855   "RTN","DGO THRP3",231 ,0)
  5856    N DGPAGE, DDASH,DGFL G,DGQ,DGST DT,DGPTNM, DGSTR,DGOL D,DGMON
  5857   "RTN","DGO THRP3",232 ,0)
  5858    N DGPR1,D GPR2,DGSTA T,DGMNAME, DGP1TOT,DG P2TOT,DGQR TR,DGC1,DG C2
  5859   "RTN","DGO THRP3",233 ,0)
  5860    S (DGQ,DG PAGE)=0,(D DASH,DGLN) ="",$P(DDA SH,"-",81) =""
  5861   "RTN","DGO THRP3",234 ,0)
  5862    I $O(@DGL IST@(""))= "" D  Q
  5863   "RTN","DGO THRP3",235 ,0)
  5864    . D HEAD
  5865   "RTN","DGO THRP3",236 ,0)
  5866    . W !!,"  >>> No Rec ords were  found usin g the repo rt criteri a.",!
  5867   "RTN","DGO THRP3",237 ,0)
  5868    ; loop an d display  report
  5869   "RTN","DGO THRP3",238 ,0)
  5870    S (DGPR1, DGPR2,DGC1 ,DGC2,DGP1 TOT,DGP2TO T)=0
  5871   "RTN","DGO THRP3",239 ,0)
  5872    S (DGCLCK ,DGPTNM,DG STR,DGOLD, DGMON,DGST AT,DGMNAME ,DGQRTR)=" "
  5873   "RTN","DGO THRP3",240 ,0)
  5874    F  S DGST AT=$O(@DGL IST@(DGSTA T)) Q:DGST AT=""  D   Q:DGQ
  5875   "RTN","DGO THRP3",241 ,0)
  5876    . F  S DG QRTR=$O(@D GLIST@(DGS TAT,DGQRTR )) Q:DGQRT R=""  D  Q :DGQ
  5877   "RTN","DGO THRP3",242 ,0)
  5878    . . ;
  5879   "RTN","DGO THRP3",243 ,0)
  5880    . . I 123 4[$P(DGSOR T("DGMON") ,U) D
  5881   "RTN","DGO THRP3",244 ,0)
  5882    . . . F   S DGMON=$O (@DGLIST@( DGSTAT,DGQ RTR,DGMON) ) Q:DGMON= ""  D  Q:D GQ
  5883   "RTN","DGO THRP3",245 ,0)
  5884    . . . . I  123[$P(DG SORT("DGMO N"),U) S D GMNAME=$P( DGSORT("DG MON"),U,2)  D HEAD
  5885   "RTN","DGO THRP3",246 ,0)
  5886    . . . . I  45[$P(DGS ORT("DGMON "),U) D
  5887   "RTN","DGO THRP3",247 ,0)
  5888    . . . . .  S DGMNAME =$P(DGSORT ("DGMON",D GMON),U)
  5889   "RTN","DGO THRP3",248 ,0)
  5890    . . . . .  I DGSTAT= "OLD" Q
  5891   "RTN","DGO THRP3",249 ,0)
  5892    . . . . .  D HEAD
  5893   "RTN","DGO THRP3",250 ,0)
  5894    . . . . W  ! D SUBHE AD(DGSTAT, DGMNAME)
  5895   "RTN","DGO THRP3",251 ,0)
  5896    . . . . D  PRINT2
  5897   "RTN","DGO THRP3",252 ,0)
  5898    . . ;
  5899   "RTN","DGO THRP3",253 ,0)
  5900    . . I 5[$ P(DGSORT(" DGMON"),U)  D
  5901   "RTN","DGO THRP3",254 ,0)
  5902    . . . I D GSTAT="OLD " Q
  5903   "RTN","DGO THRP3",255 ,0)
  5904    . . . F   S DGMON=$O (DGSORT("D GMON",DGQR TR,DGMON))  Q:DGMON=" "  D  Q:DG Q
  5905   "RTN","DGO THRP3",256 ,0)
  5906    . . . . S  DGMNAME=$ P(DGSORT(" DGMON",DGQ RTR,DGMON) ,U)
  5907   "RTN","DGO THRP3",257 ,0)
  5908    . . . . D  HEAD
  5909   "RTN","DGO THRP3",258 ,0)
  5910    . . . . W  ! D SUBHE AD(DGSTAT, DGMNAME)
  5911   "RTN","DGO THRP3",259 ,0)
  5912    . . . . D  PRINT2
  5913   "RTN","DGO THRP3",260 ,0)
  5914    . . Q:DGQ
  5915   "RTN","DGO THRP3",261 ,0)
  5916    . Q:DGQ
  5917   "RTN","DGO THRP3",262 ,0)
  5918    ;
  5919   "RTN","DGO THRP3",263 ,0)
  5920    I DGQ W:$ D(ZTQUEUED ) !!,"REPO RT STOPPED  AT USER R EQUEST" Q
  5921   "RTN","DGO THRP3",264 ,0)
  5922    N DGLN,DG TOTQ,DGTOT P1,DGTOTP2 ,DGGRND
  5923   "RTN","DGO THRP3",265 ,0)
  5924    S DGLN=""
  5925   "RTN","DGO THRP3",266 ,0)
  5926    I $E(IOST )'="C" W !
  5927   "RTN","DGO THRP3",267 ,0)
  5928    S (DGTOTQ ,DGTOTP1,D GTOTP2,DGG RND)=0
  5929   "RTN","DGO THRP3",268 ,0)
  5930    I 123[$P( DGSORT("DG MON"),U) D  MRPTSUM   ;monthly r eport summ ary
  5931   "RTN","DGO THRP3",269 ,0)
  5932    ;quarterl y report s ummary
  5933   "RTN","DGO THRP3",270 ,0)
  5934    I 45[$P(D GSORT("DGM ON"),U) D  CONT^DGOTH RP4(.DGSOR T)
  5935   "RTN","DGO THRP3",271 ,0)
  5936    W !!!,"<E ND OF REPO RT>"
  5937   "RTN","DGO THRP3",272 ,0)
  5938    Q
  5939   "RTN","DGO THRP3",273 ,0)
  5940    ;
  5941   "RTN","DGO THRP3",274 ,0)
  5942   PRINT2 ;
  5943   "RTN","DGO THRP3",275 ,0)
  5944    F  S DGPT NM=$O(@DGL IST@(DGSTA T,DGQRTR,D GMON,DGPTN M)) Q:DGPT NM=""  D   Q:DGQ
  5945   "RTN","DGO THRP3",276 ,0)
  5946    . F  S DG CLCK=$O(@D GLIST@(DGS TAT,DGQRTR ,DGMON,DGP TNM,DGCLCK )) Q:DGCLC K=""  D  Q :DGQ
  5947   "RTN","DGO THRP3",277 ,0)
  5948    . . S DGS TR=@DGLIST @(DGSTAT,D GQRTR,DGMO N,DGPTNM,D GCLCK)
  5949   "RTN","DGO THRP3",278 ,0)
  5950    . . I 45[ $P(DGSORT( "DGMON"),U ),DGSTAT=" OLD" Q
  5951   "RTN","DGO THRP3",279 ,0)
  5952    . . W !
  5953   "RTN","DGO THRP3",280 ,0)
  5954    . . I $Y> (IOSL-4) D  PAUSE^DGO THRP2(.DGQ ) Q:DGQ  D  HEAD W !
  5955   "RTN","DGO THRP3",281 ,0)
  5956    . . I DGP TNM'=DGOLD  D
  5957   "RTN","DGO THRP3",282 ,0)
  5958    . . . W $ E(DGPTNM,1 ,20),?23,$ P(DGSTR,U, 2)
  5959   "RTN","DGO THRP3",283 ,0)
  5960    . . . I 1 23[$P(DGSO RT("DGMON" ),U) D
  5961   "RTN","DGO THRP3",284 ,0)
  5962    . . . . ; D CALCFS(D GSTR,DGSTA T)  ;calcu late how m any are in  first and  second 90 -day
  5963   "RTN","DGO THRP3",285 ,0)
  5964    . . . . ; count inac tivated OT H patients  by month
  5965   "RTN","DGO THRP3",286 ,0)
  5966    . . . . D  CALCIN(DG STR,DGSTAT ,DGMON)
  5967   "RTN","DGO THRP3",287 ,0)
  5968    . . . S D GOLD=DGPTN M ;display  the name  and PID on ly once
  5969   "RTN","DGO THRP3",288 ,0)
  5970    . . W ?31 ,$P(DGSTR, U),?37,$P( DGSTR,U,3) ,?49,$P(DG STR,U,4),? 61,$S($P(D GSTR,U,7)' ="":$J("N/ A",4),1:$J ($P(DGSTR, U,5),4))
  5971   "RTN","DGO THRP3",289 ,0)
  5972    . D CALCF S(DGSTR,DG STAT)  ;ca lculate ho w many are  in first  and second  90-day
  5973   "RTN","DGO THRP3",290 ,0)
  5974    . I 45[$P (DGSORT("D GMON"),U)  D CALCIN(D GSTR,DGSTA T,DGMON) ; count inac tivated OT H patients  by month  in the qua rter
  5975   "RTN","DGO THRP3",291 ,0)
  5976    . I 45[$P (DGSORT("D GMON"),U), DGSTAT="OL D" Q
  5977   "RTN","DGO THRP3",292 ,0)
  5978    . W ?68,$ P(DGSTR,U, 7)
  5979   "RTN","DGO THRP3",293 ,0)
  5980    . Q:DGQ
  5981   "RTN","DGO THRP3",294 ,0)
  5982    ;
  5983   "RTN","DGO THRP3",295 ,0)
  5984    Q:DGQ
  5985   "RTN","DGO THRP3",296 ,0)
  5986    I DGCNT,D GSTAT="NEW " D
  5987   "RTN","DGO THRP3",297 ,0)
  5988    . N DGTIT
  5989   "RTN","DGO THRP3",298 ,0)
  5990    . S DGTIT ="New for  "_DGMNAME_ "       "
  5991   "RTN","DGO THRP3",299 ,0)
  5992    . W !!!,D GTIT,$J("= ",5)
  5993   "RTN","DGO THRP3",300 ,0)
  5994    . I 123[$ P(DGSORT(" DGMON"),U)  D
  5995   "RTN","DGO THRP3",301 ,0)
  5996    . . W $S( $G(DGCNT(D GSTAT))>0: $J(DGCNT(D GSTAT),6), 1:$J(0,6)) ,!
  5997   "RTN","DGO THRP3",302 ,0)
  5998    . . D PAU SE^DGOTHRP 2(.DGQ) Q: DGQ
  5999   "RTN","DGO THRP3",303 ,0)
  6000    . E  W $S ($G(DGCNT( DGSTAT,DGM ON))>0:$J( DGCNT(DGST AT,DGMON), $S($L(DGMN AME)<=5:9, ($L(DGMNAM E)>5)&($L( DGMNAME)<= 7):6,1:6)) ,1:$J(0,6) )
  6001   "RTN","DGO THRP3",304 ,0)
  6002    . Q:DGQ
  6003   "RTN","DGO THRP3",305 ,0)
  6004    Q:DGQ
  6005   "RTN","DGO THRP3",306 ,0)
  6006    I 4[$P(DG SORT("DGMO N"),U),DGS TAT="OLD"  Q
  6007   "RTN","DGO THRP3",307 ,0)
  6008    ;if user  select fis cal year,  before dis playing th e next mon th
  6009   "RTN","DGO THRP3",308 ,0)
  6010    ;check if  the curre nt month e valuated h as a carry  over entr y
  6011   "RTN","DGO THRP3",309 ,0)
  6012    I 5[$P(DG SORT("DGMO N"),U),$D( @DGLIST@(" OLD",DGQRT R,DGMON))  D
  6013   "RTN","DGO THRP3",310 ,0)
  6014    . W ! D P AUSE^DGOTH RP2(.DGQ)  Q:DGQ
  6015   "RTN","DGO THRP3",311 ,0)
  6016    . D PRINT FY^DGOTHRP 4(.DGSORT, .DGLIST,DG QRTR,DGMON ,DGQ,DGMNA ME)
  6017   "RTN","DGO THRP3",312 ,0)
  6018    . Q:DGQ
  6019   "RTN","DGO THRP3",313 ,0)
  6020    Q:DGQ
  6021   "RTN","DGO THRP3",314 ,0)
  6022    I (DGSTAT ="OLD")!(4 5[$P(DGSOR T("DGMON") ,U)) D
  6023   "RTN","DGO THRP3",315 ,0)
  6024    . S DGTIT ="Carry ov er for "_D GMNAME
  6025   "RTN","DGO THRP3",316 ,0)
  6026    . I 123[$ P(DGSORT(" DGMON"),U)  W !!!,DGT IT,":",$J( DGCNT("OLD "),10),!
  6027   "RTN","DGO THRP3",317 ,0)
  6028    . I 45[$P (DGSORT("D GMON"),U)  D
  6029   "RTN","DGO THRP3",318 ,0)
  6030    . . W !,D GTIT,$J("= ",5)
  6031   "RTN","DGO THRP3",319 ,0)
  6032    . . I $D( DGCNT("OLD ",DGMON))  W $J(DGCNT ("OLD",DGM ON),$S($L( DGMNAME)<= 5:9,($L(DG MNAME)>5)& ($L(DGMNAM E)<=7):6,1 :6))
  6033   "RTN","DGO THRP3",320 ,0)
  6034    . . E  W  $J(0,$S($L (DGMNAME)< =5:9,($L(D GMNAME)>5) &($L(DGMNA ME)<=7):6, 1:6))
  6035   "RTN","DGO THRP3",321 ,0)
  6036    . . W !
  6037   "RTN","DGO THRP3",322 ,0)
  6038    . . I 5[$ P(DGSORT(" DGMON"),U)  Q
  6039   "RTN","DGO THRP3",323 ,0)
  6040    . . S $P( DGLN,"=",3 5)=""
  6041   "RTN","DGO THRP3",324 ,0)
  6042    . . W DGL N,!,"TOTAL ",$J(DGCNT (DGSTAT,DG MON)+$G(DG CNT("OLD", DGMON)),$S ($L(DGMNAM E)<=8:29,1 :28)),!
  6043   "RTN","DGO THRP3",325 ,0)
  6044    . D PAUSE ^DGOTHRP2( .DGQ)
  6045   "RTN","DGO THRP3",326 ,0)
  6046    . Q:DGQ
  6047   "RTN","DGO THRP3",327 ,0)
  6048    Q
  6049   "RTN","DGO THRP3",328 ,0)
  6050    ;
  6051   "RTN","DGO THRP3",329 ,0)
  6052   CALCFS(DGS TR,DGSTAT)  ;
  6053   "RTN","DGO THRP3",330 ,0)
  6054    ;calculat e how many  OTH patie nts that w ill start
  6055   "RTN","DGO THRP3",331 ,0)
  6056    ;treatmen t in the f irst and s econd 90-D ay
  6057   "RTN","DGO THRP3",332 ,0)
  6058    I DGSTAT= "OLD" D
  6059   "RTN","DGO THRP3",333 ,0)
  6060    . I $P(DG STR,U)=1 S  DGC1=DGC1 +1
  6061   "RTN","DGO THRP3",334 ,0)
  6062    . I $P(DG STR,U)=2 S  DGC2=DGC2 +1
  6063   "RTN","DGO THRP3",335 ,0)
  6064    E  D
  6065   "RTN","DGO THRP3",336 ,0)
  6066    . I $P(DG STR,U)=1 S  DGPR1=DGP R1+1
  6067   "RTN","DGO THRP3",337 ,0)
  6068    . I $P(DG STR,U)=2 S  DGPR2=DGP R2+1
  6069   "RTN","DGO THRP3",338 ,0)
  6070    S DGP1TOT =DGPR1+DGC 1
  6071   "RTN","DGO THRP3",339 ,0)
  6072    S DGP2TOT =DGPR2+DGC 2
  6073   "RTN","DGO THRP3",340 ,0)
  6074    Q
  6075   "RTN","DGO THRP3",341 ,0)
  6076    ;
  6077   "RTN","DGO THRP3",342 ,0)
  6078   CALCIN(DGS TR,DGSTAT, DGMON) ;ca lculate in activated  OTH patien ts
  6079   "RTN","DGO THRP3",343 ,0)
  6080    I $P(DGST R,U,7)'=""  D
  6081   "RTN","DGO THRP3",344 ,0)
  6082    . I 123[$ P(DGSORT(" DGMON"),U)  D
  6083   "RTN","DGO THRP3",345 ,0)
  6084    . . I DGS TAT="OLD"  S DGCNT("I NCRY")=$G( DGCNT("INC RY"))+1
  6085   "RTN","DGO THRP3",346 ,0)
  6086    . . E  S  DGCNT("INN EW")=$G(DG CNT("INNEW "))+1
  6087   "RTN","DGO THRP3",347 ,0)
  6088    . I 45[$P (DGSORT("D GMON"),U)  S DGCNT("I N",DGMON)= $G(DGCNT(" IN",DGMON) )+1
  6089   "RTN","DGO THRP3",348 ,0)
  6090    Q
  6091   "RTN","DGO THRP3",349 ,0)
  6092    ;
  6093   "RTN","DGO THRP3",350 ,0)
  6094   MRPTSUM ;m onthly rep ort summar y
  6095   "RTN","DGO THRP3",351 ,0)
  6096    D HEAD
  6097   "RTN","DGO THRP3",352 ,0)
  6098    W !!,"New ly Registe red OTH Pa tients for  the month  of ",DGMN AME,":"
  6099   "RTN","DGO THRP3",353 ,0)
  6100    W !!,"REP ORT SUMMAR Y:"
  6101   "RTN","DGO THRP3",354 ,0)
  6102    W !!,?26, "1st 90-Da y",?40,"2n d 90-Day", ?54,"TOTAL ",?69,"INA CTIVATED"
  6103   "RTN","DGO THRP3",355 ,0)
  6104    S $P(DGLN ,"=",11)=" " W !,?26, DGLN,?40,D GLN,?54,"= ===="
  6105   "RTN","DGO THRP3",356 ,0)
  6106    S $P(DGLN ,"=",12)=" " W ?69,DG LN
  6107   "RTN","DGO THRP3",357 ,0)
  6108    W !!,"New  for ",DGM NAME,":",? 26,$J(DGPR 1,6),?40,$ J(DGPR2,6)
  6109   "RTN","DGO THRP3",358 ,0)
  6110    W ?54,$S( $G(DGCNT(" NEW"))>0:$ J(DGCNT("N EW"),5),1: $J(0,5))
  6111   "RTN","DGO THRP3",359 ,0)
  6112    W ?69,$S( $G(DGCNT(" INNEW"))>0 :$J(DGCNT( "INNEW"),6 ),1:$J(0,6 ))
  6113   "RTN","DGO THRP3",360 ,0)
  6114    W !,"Carr y over for  ",DGMNAME ,":",?25,$ J(DGC1,7), ?39,$J(DGC 2,7)
  6115   "RTN","DGO THRP3",361 ,0)
  6116    W ?53,$S( $G(DGCNT(" OLD"))>0:$ J(DGCNT("O LD"),6),1: $J(0,6))
  6117   "RTN","DGO THRP3",362 ,0)
  6118    W ?69,$S( $G(DGCNT(" INCRY"))>0 :$J(DGCNT( "INCRY"),6 ),1:$J(0,6 ))
  6119   "RTN","DGO THRP3",363 ,0)
  6120    W !,DDASH
  6121   "RTN","DGO THRP3",364 ,0)
  6122    W !,"TOTA L",?26,$J( DGP1TOT,6) ,?40,$J(DG P2TOT,6),? 54,$J(DGCN T,5),?69,$ J($G(DGCNT ("INNEW")) +$G(DGCNT( "INCRY")), 6)
  6123   "RTN","DGO THRP3",365 ,0)
  6124    Q
  6125   "RTN","DGO THRP3",366 ,0)
  6126    ;
  6127   "RTN","DGO THRP3",367 ,0)
  6128   MONAME ;Mo nth Name
  6129   "RTN","DGO THRP3",368 ,0)
  6130    ;;1^Janua ry
  6131   "RTN","DGO THRP3",369 ,0)
  6132    ;;2^Febru ary
  6133   "RTN","DGO THRP3",370 ,0)
  6134    ;;3^March
  6135   "RTN","DGO THRP3",371 ,0)
  6136    ;;4^April
  6137   "RTN","DGO THRP3",372 ,0)
  6138    ;;5^May
  6139   "RTN","DGO THRP3",373 ,0)
  6140    ;;6^June
  6141   "RTN","DGO THRP3",374 ,0)
  6142    ;;7^July
  6143   "RTN","DGO THRP3",375 ,0)
  6144    ;;8^Augus t
  6145   "RTN","DGO THRP3",376 ,0)
  6146    ;;9^Septe mber
  6147   "RTN","DGO THRP3",377 ,0)
  6148    ;;10^Octo ber
  6149   "RTN","DGO THRP3",378 ,0)
  6150    ;;11^Nove mber
  6151   "RTN","DGO THRP3",379 ,0)
  6152    ;;12^Dece mber
  6153   "RTN","DGO THRP3",380 ,0)
  6154    Q
  6155   "RTN","DGO THRP3",381 ,0)
  6156    ;
  6157   "RTN","DGO THRP3",382 ,0)
  6158   HEAD ;Prin t/Display  Page Heade r Detail
  6159   "RTN","DGO THRP3",383 ,0)
  6160    I $D(ZTQU EUED),$$S^ %ZTLOAD S  (ZTSTOP,DG Q)=1 Q
  6161   "RTN","DGO THRP3",384 ,0)
  6162    N DGFACLT Y,DGPRD
  6163   "RTN","DGO THRP3",385 ,0)
  6164    I TRM!('T RM&DGPAGE)  W @IOF
  6165   "RTN","DGO THRP3",386 ,0)
  6166    S DGPAGE= $G(DGPAGE) +1
  6167   "RTN","DGO THRP3",387 ,0)
  6168    S DGFACLT Y="Facilit y: "_$P(HE RE,U,2)
  6169   "RTN","DGO THRP3",388 ,0)
  6170    W !,?80-$ L(ZTDESC)\ 2,$G(ZTDES C),?71,"Pa ge:",?77,D GPAGE
  6171   "RTN","DGO THRP3",389 ,0)
  6172    W !,?80-$ L(DGFACLTY )\2,DGFACL TY ;facili ty
  6173   "RTN","DGO THRP3",390 ,0)
  6174    S DGPRD=" Report Per iod: "_$S( 123[$P(DGS ORT("DGMON "),U):"Mon th of "_$P (DGSORT("D GMON"),U,2 ),1:$P(DGS ORT("DGMON "),U,2))
  6175   "RTN","DGO THRP3",391 ,0)
  6176    W !,?80-$ L(DGPRD)\2 ,DGPRD
  6177   "RTN","DGO THRP3",392 ,0)
  6178    W !,"Date  Range:",? 12,DGDTRNG E
  6179   "RTN","DGO THRP3",393 ,0)
  6180    W ?45,"Da te Printed :",?59,$$F MTE^XLFDT( $$NOW^XLFD T,"MP")
  6181   "RTN","DGO THRP3",394 ,0)
  6182    W !,DDASH
  6183   "RTN","DGO THRP3",395 ,0)
  6184    W !,"PATI ENT NAME", ?23,"PID", ?29,"PERIO D",?37,"ST ART DATE", ?49,"END D ATE",?61," DAYS",?68, "INACTIVAT ION"
  6185   "RTN","DGO THRP3",396 ,0)
  6186    W !,?61," LEFT",?68, "DATE"
  6187   "RTN","DGO THRP3",397 ,0)
  6188    W !,DDASH
  6189   "RTN","DGO THRP3",398 ,0)
  6190    Q
  6191   "RTN","DGO THRP3",399 ,0)
  6192    ;
  6193   "RTN","DGO THRP3",400 ,0)
  6194   SUBHEAD(DG STAT,DGMNA ME) ;displ ay sub hea der
  6195   "RTN","DGO THRP3",401 ,0)
  6196    I 4[$P(DG SORT("DGMO N"),U),DGS TAT="OLD"  Q
  6197   "RTN","DGO THRP3",402 ,0)
  6198    W !,$S(DG STAT="OLD" :"Carry-ov er OTH Pat ients for  ",1:"OTH P atients th at started  treatment  in  ")
  6199   "RTN","DGO THRP3",403 ,0)
  6200    W DGMNAME _":"
  6201   "RTN","DGO THRP3",404 ,0)
  6202    W !
  6203   "RTN","DGO THRP3",405 ,0)
  6204    Q
  6205   "RTN","DGO THRP3",406 ,0)
  6206    ;
  6207   "RTN","DGO THRP3",407 ,0)
  6208   HELP ;prov ide extend ed DIR("?" ) help tex t.
  6209   "RTN","DGO THRP3",408 ,0)
  6210    ;
  6211   "RTN","DGO THRP3",409 ,0)
  6212    I X'="?", X'="??" W  !,"  Not a  valid fis cal year." ,!
  6213   "RTN","DGO THRP3",410 ,0)
  6214    W !,"  En ter the fi scal year  in this fo rmat: YY o r YYYY"
  6215   "RTN","DGO THRP3",411 ,0)
  6216    Q
  6217   "RTN","DGO THRP3",412 ,0)
  6218    ;
  6219   "RTN","DGO THRP4")
  6220   0^13^B2165 8061
  6221   "RTN","DGO THRP4",1,0 )
  6222   DGOTHRP4 ; SLC/RM - O TH PATIENT  PERIOD ST ATUS REPOR T CONT. ;J uly 20, 20 18@5:15
  6223   "RTN","DGO THRP4",2,0 )
  6224    ;;5.3;Reg istration; **952**;Au g 13, 1993 ;Build 68
  6225   "RTN","DGO THRP4",3,0 )
  6226    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  6227   "RTN","DGO THRP4",4,0 )
  6228    ;
  6229   "RTN","DGO THRP4",5,0 )
  6230    ;     Las t Edited:  SHRPE/RM -  July 20,  2018 5:15
  6231   "RTN","DGO THRP4",6,0 )
  6232    ;
  6233   "RTN","DGO THRP4",7,0 )
  6234    ; ICR# TY PE      DE SCRIPTION
  6235   "RTN","DGO THRP4",8,0 )
  6236    ;----- -- --      -- ---------- ---------
  6237   "RTN","DGO THRP4",9,0 )
  6238    ;10024 Su p       WA IT^DICD
  6239   "RTN","DGO THRP4",10, 0)
  6240    ;10063 Su p       $$ S^%ZTLOAD
  6241   "RTN","DGO THRP4",11, 0)
  6242    ;10086 Su p       HO ME^%ZIS
  6243   "RTN","DGO THRP4",12, 0)
  6244    ;10089 Su p       ^% ZISC
  6245   "RTN","DGO THRP4",13, 0)
  6246    ;10103 Su p       ^X LFDT: $$FM TE, $$NOW
  6247   "RTN","DGO THRP4",14, 0)
  6248    ;10112 Su p       $$ SITE^VASIT E
  6249   "RTN","DGO THRP4",15, 0)
  6250    ;10015 Su p       GE TS^DIQ
  6251   "RTN","DGO THRP4",16, 0)
  6252    ;10026 Su p       ^D IR
  6253   "RTN","DGO THRP4",17, 0)
  6254    ;6873  Co nt Sub  $$ OTHDCLCK^D GOTHD
  6255   "RTN","DGO THRP4",18, 0)
  6256    ;
  6257   "RTN","DGO THRP4",19, 0)
  6258    ;- no dir ect entry
  6259   "RTN","DGO THRP4",20, 0)
  6260    Q
  6261   "RTN","DGO THRP4",21, 0)
  6262    ;
  6263   "RTN","DGO THRP4",22, 0)
  6264   CONT(DGSOR T) ;Statis tical Repo rt continu ation
  6265   "RTN","DGO THRP4",23, 0)
  6266    N DGMON,D GQRTR,DGNW TOT,DGCRYT OT,DGINTOT ,DGFYAR,DG CARY,DGLN
  6267   "RTN","DGO THRP4",24, 0)
  6268    ;quarterl y report s ummary
  6269   "RTN","DGO THRP4",25, 0)
  6270    I 4[$P(DG SORT("DGMO N"),U) D
  6271   "RTN","DGO THRP4",26, 0)
  6272    . D QRPTH D
  6273   "RTN","DGO THRP4",27, 0)
  6274    . S DGMON ="" F  S D GMON=$O(DG SORT("DGMO N",DGMON))  Q:DGMON=" "  D
  6275   "RTN","DGO THRP4",28, 0)
  6276    . . D QRP TSUM
  6277   "RTN","DGO THRP4",29, 0)
  6278    . D QRPTS UM1
  6279   "RTN","DGO THRP4",30, 0)
  6280    ;fiscal y ear report  summary
  6281   "RTN","DGO THRP4",31, 0)
  6282    I 5[$P(DG SORT("DGMO N"),U) D
  6283   "RTN","DGO THRP4",32, 0)
  6284    . N I,DGL N
  6285   "RTN","DGO THRP4",33, 0)
  6286    . D QRPTH D
  6287   "RTN","DGO THRP4",34, 0)
  6288    . S (DGQR TR,DGMON)= ""
  6289   "RTN","DGO THRP4",35, 0)
  6290    . W !
  6291   "RTN","DGO THRP4",36, 0)
  6292    . S DGQRT R="" F  S  DGQRTR=$O( DGSORT("DG MON",DGQRT R)) Q:DGQR TR=""  D
  6293   "RTN","DGO THRP4",37, 0)
  6294    . . W !," FY QUARTER  ",DGQRTR, ":"
  6295   "RTN","DGO THRP4",38, 0)
  6296    . . S (DG NWTOT,DGCR YTOT,DGINT OT)=0
  6297   "RTN","DGO THRP4",39, 0)
  6298    . . S DGM ON="" F  S  DGMON=$O( DGSORT("DG MON",DGQRT R,DGMON))  Q:DGMON=""   D
  6299   "RTN","DGO THRP4",40, 0)
  6300    . . . D Q RPTSUM
  6301   "RTN","DGO THRP4",41, 0)
  6302    . . D QRP TSUM1
  6303   "RTN","DGO THRP4",42, 0)
  6304    . . W !
  6305   "RTN","DGO THRP4",43, 0)
  6306    . I $D(DG FYAR) D
  6307   "RTN","DGO THRP4",44, 0)
  6308    . . W !!, "FISCAL YE AR OVER AL L SUMMARY: ",!
  6309   "RTN","DGO THRP4",45, 0)
  6310    . . F I=1 :1:4 D
  6311   "RTN","DGO THRP4",46, 0)
  6312    . . . W ! ,"FY QUART ER ",I
  6313   "RTN","DGO THRP4",47, 0)
  6314    . . . W ? 20,$J($P(D GFYAR(I),U ),4),?30,$ J($P(DGFYA R(I),U,2), 6)
  6315   "RTN","DGO THRP4",48, 0)
  6316    . . . W ? 44,$J($P(D GFYAR(I),U ,3),5),?69 ,$J($P(DGF YAR(I),U,4 ),6)
  6317   "RTN","DGO THRP4",49, 0)
  6318    . . S $P( DGLN,"=",8 1)=""
  6319   "RTN","DGO THRP4",50, 0)
  6320    . . W !,D GLN,"TOTAL  INACTIVAT ED FOR THE  YEAR:",?6 9,$J(DGCNT ("IN"),6)
  6321   "RTN","DGO THRP4",51, 0)
  6322    . . ;W !! ,"TOTAL OC CURRENCE O F TREATMEN TS:",!!,?2 0,"New",?3 0,"Carry O ver",?44," TOTAL"
  6323   "RTN","DGO THRP4",52, 0)
  6324    . . ;W !, ?20,"----" ,?30,"---- ------",?4 4,"-----"
  6325   "RTN","DGO THRP4",53, 0)
  6326    . . ;W !? 20,$J(DGCN T("NEW"),4 ),?30,$J(D GCNT("OLD" ),6),?44,$ J(DGCNT,5)
  6327   "RTN","DGO THRP4",54, 0)
  6328    . . ;W !! ,"ADJUSTME NT**",?44, $J(($G(DGC NT)-$G(DGN ET)),5)
  6329   "RTN","DGO THRP4",55, 0)
  6330    . . ;N DG LN S $P(DG LN,"-",50) ="" W !,DG LN
  6331   "RTN","DGO THRP4",56, 0)
  6332    . . W !!, "TOTAL NUM BER OF UNI QUE PATIEN TS TREATED  FOR ",DGD TRNGE,":   ",$J($G(DG NET),3)
  6333   "RTN","DGO THRP4",57, 0)
  6334    . . ;W !! ,"** These  patients  are only c ounted onc e:"
  6335   "RTN","DGO THRP4",58, 0)
  6336    . . ;W !, "     Pati ents recei ving an ad ditional 9 0 Days of  Care"
  6337   "RTN","DGO THRP4",59, 0)
  6338    . . ;W !, "     Carr y-Over Pat ients"
  6339   "RTN","DGO THRP4",60, 0)
  6340    Q
  6341   "RTN","DGO THRP4",61, 0)
  6342    ;
  6343   "RTN","DGO THRP4",62, 0)
  6344   QRPTHD ;qu arterly/fi scal repor t subheade r
  6345   "RTN","DGO THRP4",63, 0)
  6346    N DGLN
  6347   "RTN","DGO THRP4",64, 0)
  6348    D HEAD^DG OTHRP3
  6349   "RTN","DGO THRP4",65, 0)
  6350    W !!,"REP ORT SUMMAR Y FOR ",DG DTRNGE,":"
  6351   "RTN","DGO THRP4",66, 0)
  6352    W !!,"Mon th",?20,"N ew",?30,"C arry Over" ,?44,"TOTA L",?69,"IN ACTIVATED"
  6353   "RTN","DGO THRP4",67, 0)
  6354    S $P(DGLN ,"=",10)=" " W !,DGLN ,?20,"==== ",?30,DGLN ,?44,"==== ="
  6355   "RTN","DGO THRP4",68, 0)
  6356    S $P(DGLN ,"=",12)=" " W ?69,DG LN
  6357   "RTN","DGO THRP4",69, 0)
  6358    Q
  6359   "RTN","DGO THRP4",70, 0)
  6360    ;
  6361   "RTN","DGO THRP4",71, 0)
  6362   QRPTSUM ;q uarterly r eport summ ary
  6363   "RTN","DGO THRP4",72, 0)
  6364    N DGNEW,D GCARY
  6365   "RTN","DGO THRP4",73, 0)
  6366    S DGNEW=$ S($G(DGCNT ("NEW",DGM ON))>0:DGC NT("NEW",D GMON),1:0)
  6367   "RTN","DGO THRP4",74, 0)
  6368    S DGCARY= $S($G(DGCN T("OLD",DG MON))>0:DG CNT("OLD", DGMON),1:0 )
  6369   "RTN","DGO THRP4",75, 0)
  6370    S DGNWTOT =$G(DGNWTO T)+$G(DGCN T("NEW",DG MON))
  6371   "RTN","DGO THRP4",76, 0)
  6372    S DGCRYTO T=$G(DGCRY TOT)+$G(DG CNT("OLD", DGMON))
  6373   "RTN","DGO THRP4",77, 0)
  6374    S DGINTOT =$G(DGINTO T)+$G(DGCN T("IN",DGM ON))
  6375   "RTN","DGO THRP4",78, 0)
  6376    W !
  6377   "RTN","DGO THRP4",79, 0)
  6378    I 4[$P(DG SORT("DGMO N"),U) W $ P(DGSORT(" DGMON",DGM ON),U)
  6379   "RTN","DGO THRP4",80, 0)
  6380    I 5[$P(DG SORT("DGMO N"),U) W "   ",$P(DGS ORT("DGMON ",DGQRTR,D GMON),U)
  6381   "RTN","DGO THRP4",81, 0)
  6382    W ?20,$J( DGNEW,4),? 30,$J(DGCA RY,6),?44, $J(DGNEW+D GCARY,5),? 69,$S($G(D GCNT("IN", DGMON))>0: $J(DGCNT(" IN",DGMON) ,6),1:$J(0 ,6))
  6383   "RTN","DGO THRP4",82, 0)
  6384    Q
  6385   "RTN","DGO THRP4",83, 0)
  6386    ;
  6387   "RTN","DGO THRP4",84, 0)
  6388   QRPTSUM1 ; display gr and total  for quarte rly/fiscal  quarterly  report su mmary
  6389   "RTN","DGO THRP4",85, 0)
  6390    N DGLN
  6391   "RTN","DGO THRP4",86, 0)
  6392    S $P(DGLN ,"=",81)=" "
  6393   "RTN","DGO THRP4",87, 0)
  6394    W !,DGLN
  6395   "RTN","DGO THRP4",88, 0)
  6396    W !,"TOTA L",?20,$J( DGNWTOT,4) ,?30,$J(DG CRYTOT,6)
  6397   "RTN","DGO THRP4",89, 0)
  6398    W ?44,$S( 4[$P(DGSOR T("DGMON") ,U):$J(DGC NT,5),1:$J ($G(DGNWTO T)+$G(DGCR YTOT),5))
  6399   "RTN","DGO THRP4",90, 0)
  6400    W ?69,$J( DGINTOT,6)
  6401   "RTN","DGO THRP4",91, 0)
  6402    I 5[$P(DG SORT("DGMO N"),U) D
  6403   "RTN","DGO THRP4",92, 0)
  6404    . S DGFYA R(DGQRTR)= DGNWTOT_U_ DGCRYTOT_U _($G(DGNWT OT)+$G(DGC RYTOT))_U_ DGINTOT
  6405   "RTN","DGO THRP4",93, 0)
  6406    . S DGCNT ("IN")=$G( DGCNT("IN" ))+DGINTOT
  6407   "RTN","DGO THRP4",94, 0)
  6408    Q
  6409   "RTN","DGO THRP4",95, 0)
  6410    ;
  6411   "RTN","DGO THRP4",96, 0)
  6412   PRINTFY(DG SORT,DGLIS T,DGQRTR,D GMON,DGQ,D GMNAME) ;p rint/displ ay carry o ver OTH pa tients
  6413   "RTN","DGO THRP4",97, 0)
  6414    N DGSTAT, DGPTNM,DGC LCK,DGSTR, DGOLD
  6415   "RTN","DGO THRP4",98, 0)
  6416    S DGSTAT= "OLD",(DGO LD,DGPTNM, DGCLCK,DGS TR)=""
  6417   "RTN","DGO THRP4",99, 0)
  6418    D HEAD^DG OTHRP3
  6419   "RTN","DGO THRP4",100 ,0)
  6420    W ! D SUB HEAD^DGOTH RP3(DGSTAT ,DGMNAME)
  6421   "RTN","DGO THRP4",101 ,0)
  6422    F  S DGPT NM=$O(@DGL IST@(DGSTA T,DGQRTR,D GMON,DGPTN M)) Q:DGPT NM=""  D   Q:DGQ
  6423   "RTN","DGO THRP4",102 ,0)
  6424    . F  S DG CLCK=$O(@D GLIST@(DGS TAT,DGQRTR ,DGMON,DGP TNM,DGCLCK )) Q:DGCLC K=""  D  Q :DGQ
  6425   "RTN","DGO THRP4",103 ,0)
  6426    . . S DGS TR=@DGLIST @(DGSTAT,D GQRTR,DGMO N,DGPTNM,D GCLCK)
  6427   "RTN","DGO THRP4",104 ,0)
  6428    . . W !
  6429   "RTN","DGO THRP4",105 ,0)
  6430    . . I $Y> (IOSL-4) D  PAUSE^DGO THRP2(.DGQ ) Q:DGQ  D  HEAD^DGOT HRP3 W !
  6431   "RTN","DGO THRP4",106 ,0)
  6432    . . I DGP TNM'=DGOLD  D
  6433   "RTN","DGO THRP4",107 ,0)
  6434    . . . W $ E(DGPTNM,1 ,20),?23,$ P(DGSTR,U, 2)
  6435   "RTN","DGO THRP4",108 ,0)
  6436    . . . S D GOLD=DGPTN M ;display  the name  and PID on ly once
  6437   "RTN","DGO THRP4",109 ,0)
  6438    . . W ?31 ,$P(DGSTR, U),?37,$P( DGSTR,U,3) ,?49,$P(DG STR,U,4),? 61,$S($P(D GSTR,U,7)' ="":$J("N/ A",4),1:$J ($P(DGSTR, U,5),4))
  6439   "RTN","DGO THRP4",110 ,0)
  6440    . W ?68,$ P(DGSTR,U, 7)
  6441   "RTN","DGO THRP4",111 ,0)
  6442    . D CALCI N^DGOTHRP3 (DGSTR,DGS TAT,DGMON)   ;count i nactivated  OTH patie nts by mon th in the  quarter
  6443   "RTN","DGO THRP4",112 ,0)
  6444    . Q:DGQ
  6445   "RTN","DGO THRP4",113 ,0)
  6446    W !!
  6447   "RTN","DGO THRP4",114 ,0)
  6448    Q
  6449   "RTN","DGO THRP4",115 ,0)
  6450    ;
  6451   "RTN","DGO THRPT")
  6452   0^8^B13950 4206
  6453   "RTN","DGO THRPT",1,0 )
  6454   DGOTHRPT ; SLC/RM - O THD (OTHER  THAN HONO RABLE DISC HARGE) API s ;April 2 7,2018@21: 08
  6455   "RTN","DGO THRPT",2,0 )
  6456    ;;5.3;Reg istration; **952**;Au g 13, 1993 ;Build 68
  6457   "RTN","DGO THRPT",3,0 )
  6458    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  6459   "RTN","DGO THRPT",4,0 )
  6460    ;
  6461   "RTN","DGO THRPT",5,0 )
  6462    ;     Las t Edited:  SHRPE/RM -  May 02, 2 018 15:50
  6463   "RTN","DGO THRPT",6,0 )
  6464    ;
  6465   "RTN","DGO THRPT",7,0 )
  6466    ; ICR#  T YPE  DESCR IPTION
  6467   "RTN","DGO THRPT",8,0 )
  6468    ;-----  - ---  ----- ---------- ---------- ------
  6469   "RTN","DGO THRPT",9,0 )
  6470    ; 10010   Sup  EN1^D IP
  6471   "RTN","DGO THRPT",10, 0)
  6472    ; 10006   Sup  ^DIC
  6473   "RTN","DGO THRPT",11, 0)
  6474    ; 10086   Sup  HOME^ %ZIS
  6475   "RTN","DGO THRPT",12, 0)
  6476    ; 10103   Sup  ^XLFD T:$$FMTE,  $$NOW, $$F MADD
  6477   "RTN","DGO THRPT",13, 0)
  6478    ; 1519    Sup  EN^XU TMDEVQ
  6479   "RTN","DGO THRPT",14, 0)
  6480    ; 10026   Sup  ^DIR
  6481   "RTN","DGO THRPT",15, 0)
  6482    Q
  6483   "RTN","DGO THRPT",16, 0)
  6484    ;
  6485   "RTN","DGO THRPT",17, 0)
  6486    ;Entry po int DG OTH  HISTORY A UDIT REPOR T option
  6487   "RTN","DGO THRPT",18, 0)
  6488    ;B2S4
  6489   "RTN","DGO THRPT",19, 0)
  6490    ;
  6491   "RTN","DGO THRPT",20, 0)
  6492   EN ;
  6493   "RTN","DGO THRPT",21, 0)
  6494    N DGLOOP
  6495   "RTN","DGO THRPT",22, 0)
  6496    S DGLOOP= 0
  6497   "RTN","DGO THRPT",23, 0)
  6498    ;keep ask ing until  empty inpu t
  6499   "RTN","DGO THRPT",24, 0)
  6500    F  D  Q:D GLOOP=1
  6501   "RTN","DGO THRPT",25, 0)
  6502    . N DGIEN 33,DFN,L,F LDS,BY,DHD ,FR,TO,DGA RR
  6503   "RTN","DGO THRPT",26, 0)
  6504    . W !
  6505   "RTN","DGO THRPT",27, 0)
  6506    . S DGIEN 33=$$SELPA T(.DGARR)
  6507   "RTN","DGO THRPT",28, 0)
  6508    . I DGIEN 33<0 S DGL OOP=1 Q
  6509   "RTN","DGO THRPT",29, 0)
  6510    . S L=0,D IC="^DGOTH (33.1,"
  6511   "RTN","DGO THRPT",30, 0)
  6512    . S FLDS= "[DG OTH P RINT TEMPL ATE]"
  6513   "RTN","DGO THRPT",31, 0)
  6514    . S BY="@ .01"
  6515   "RTN","DGO THRPT",32, 0)
  6516    . S DHD=" OTHER THAN  HONORABLE  AUDIT HIS TORY REPOR T"
  6517   "RTN","DGO THRPT",33, 0)
  6518    . S (FR(1 ),TO(1))=D GIEN33
  6519   "RTN","DGO THRPT",34, 0)
  6520    . D EN1^D IP
  6521   "RTN","DGO THRPT",35, 0)
  6522    Q
  6523   "RTN","DGO THRPT",36, 0)
  6524    ;
  6525   "RTN","DGO THRPT",37, 0)
  6526   SELPAT(DGP AT) ;
  6527   "RTN","DGO THRPT",38, 0)
  6528    ;- int in put vars f or ^DIC ca ll
  6529   "RTN","DGO THRPT",39, 0)
  6530    N DIC,DTO UT,DUOUT,X ,Y
  6531   "RTN","DGO THRPT",40, 0)
  6532    S DIC="^D GOTH(33.1, ",DIC(0)=" AEMQZV"
  6533   "RTN","DGO THRPT",41, 0)
  6534    S DIC("?P ARAM",33.1 ,"INDEX")= .01
  6535   "RTN","DGO THRPT",42, 0)
  6536    ;- lookup  patient
  6537   "RTN","DGO THRPT",43, 0)
  6538    D ^DIC K  DIC
  6539   "RTN","DGO THRPT",44, 0)
  6540    ;- result  of lookup
  6541   "RTN","DGO THRPT",45, 0)
  6542    S DGPAT=Y
  6543   "RTN","DGO THRPT",46, 0)
  6544    ;- if suc cess, setu p return a rray using  output va rs from ^D IC call
  6545   "RTN","DGO THRPT",47, 0)
  6546    I (+DGPAT >0) D  Q Y (0,0)  ;pa tient name
  6547   "RTN","DGO THRPT",48, 0)
  6548    . S DGPAT =+Y               ;pa tient ien
  6549   "RTN","DGO THRPT",49, 0)
  6550    . S DGPAT (0)=$G(Y(0 ))     ;ze ro node of  patient i n (#33.1)  file
  6551   "RTN","DGO THRPT",50, 0)
  6552    Q -1
  6553   "RTN","DGO THRPT",51, 0)
  6554    ;
  6555   "RTN","DGO THRPT",52, 0)
  6556   RSNMSG ;di splay reas on
  6557   "RTN","DGO THRPT",53, 0)
  6558    W !,?0 W  "Reason           :"
  6559   "RTN","DGO THRPT",54, 0)
  6560    W ?20 S Y =$P(X,U,8)  S Y(0)=Y  S:Y="" Y=" N/A" W $E( Y,1,60)
  6561   "RTN","DGO THRPT",55, 0)
  6562    Q
  6563   "RTN","DGO THRPT",56, 0)
  6564    ;
  6565   "RTN","DGO THRPT",57, 0)
  6566    ;Entry po int for DG  OTH ACTIV E 90-DAY P ERIOD opti on
  6567   "RTN","DGO THRPT",58, 0)
  6568    ;B3S1
  6569   "RTN","DGO THRPT",59, 0)
  6570   REPORT1 ;
  6571   "RTN","DGO THRPT",60, 0)
  6572    ;This sub routine wi ll be used  for selec ting sort  parameters
  6573   "RTN","DGO THRPT",61, 0)
  6574    ;to displ ay all act ive OTH pa tients
  6575   "RTN","DGO THRPT",62, 0)
  6576    ;
  6577   "RTN","DGO THRPT",63, 0)
  6578    ;Reports  can be sor ted by:
  6579   "RTN","DGO THRPT",64, 0)
  6580    ; 1) Name
  6581   "RTN","DGO THRPT",65, 0)
  6582    ; 2) Peri od
  6583   "RTN","DGO THRPT",66, 0)
  6584    ; 3) Days  Remaining
  6585   "RTN","DGO THRPT",67, 0)
  6586    ;
  6587   "RTN","DGO THRPT",68, 0)
  6588    ;The foll owing repo rting sort  array wil l be built  by user p rompts:
  6589   "RTN","DGO THRPT",69, 0)
  6590    ; DGSORT( "DGBEG") =  BEGINNING  DATE (int ernal File Man date)
  6591   "RTN","DGO THRPT",70, 0)
  6592    ; DGSORT( "DGEND") =  ENDING DA TE (intern al FileMan  date)
  6593   "RTN","DGO THRPT",71, 0)
  6594    ; DGSORT( "DGSRTBY")  = SORT BY
  6595   "RTN","DGO THRPT",72, 0)
  6596    ; DGSORT( "DGSTATUS" ) = OTH Pa tient Stat us to repo rt on
  6597   "RTN","DGO THRPT",73, 0)
  6598    ; 1^Activ e Period
  6599   "RTN","DGO THRPT",74, 0)
  6600    ;
  6601   "RTN","DGO THRPT",75, 0)
  6602    ; prompts  for repor t selectio n sorts
  6603   "RTN","DGO THRPT",76, 0)
  6604    ; Input:  none
  6605   "RTN","DGO THRPT",77, 0)
  6606    ; Output:  Report ge nerated us ing user s elected pa rameters
  6607   "RTN","DGO THRPT",78, 0)
  6608    ;
  6609   "RTN","DGO THRPT",79, 0)
  6610    N DGFIRST   ;first O TH patient  DFN
  6611   "RTN","DGO THRPT",80, 0)
  6612    N DGSEL     ;help te xt var
  6613   "RTN","DGO THRPT",81, 0)
  6614    N DGSORT    ;array o r report p arameters
  6615   "RTN","DGO THRPT",82, 0)
  6616    N ZTSAVE    ;open ar ray refere nce of inp ut paramet ers used b y tasking
  6617   "RTN","DGO THRPT",83, 0)
  6618    N ZTDESC    ;contain s the free -text desc ription of  your task  that you  passed to  the Progra m Interfac e.
  6619   "RTN","DGO THRPT",84, 0)
  6620    N ZTQUEUE D ;backgro und execut ion
  6621   "RTN","DGO THRPT",85, 0)
  6622    N ZTREQ     ;post-ex ecution
  6623   "RTN","DGO THRPT",86, 0)
  6624    N ZTSTOP
  6625   "RTN","DGO THRPT",87, 0)
  6626    ;
  6627   "RTN","DGO THRPT",88, 0)
  6628    ;check fo r database
  6629   "RTN","DGO THRPT",89, 0)
  6630    S DGFIRST =$P(+$O(^D GOTH(33,"B ","")),"," ) ;first O TH DFN
  6631   "RTN","DGO THRPT",90, 0)
  6632    I 'DGFIRS T D  Q
  6633   "RTN","DGO THRPT",91, 0)
  6634    . W !?2," >>> No Oth er Than Ho norable Pa tient Reco rd have be en found." ,*7
  6635   "RTN","DGO THRPT",92, 0)
  6636    . I $$ANS WER("Enter  RETURN to  continue" ,"","E")
  6637   "RTN","DGO THRPT",93, 0)
  6638    ;
  6639   "RTN","DGO THRPT",94, 0)
  6640    W @IOF
  6641   "RTN","DGO THRPT",95, 0)
  6642    W !,"This  option ge nerates a  report tha t will dis play a lis ting of al l"
  6643   "RTN","DGO THRPT",96, 0)
  6644    W !,"Othe r Than Hon orable pat ients with  ACTIVE 90 -Day perio d of care. "
  6645   "RTN","DGO THRPT",97, 0)
  6646    W !!,"OTH ER THAN HO NORABLE AC TIVE 90-DA Y PERIOD R EPORT"
  6647   "RTN","DGO THRPT",98, 0)
  6648    S DGSORT( "DGSTATUS" )="1^Activ e Period"  ;defaulted  to only d isplay all  active 90 -Day perio d
  6649   "RTN","DGO THRPT",99, 0)
  6650    ;prompt f or beginni ng date
  6651   "RTN","DGO THRPT",100 ,0)
  6652    I '$$DATE BEG Q
  6653   "RTN","DGO THRPT",101 ,0)
  6654    ;
  6655   "RTN","DGO THRPT",102 ,0)
  6656    ;prompt f or ending  date
  6657   "RTN","DGO THRPT",103 ,0)
  6658    I '$$DATE END Q
  6659   "RTN","DGO THRPT",104 ,0)
  6660    ;
  6661   "RTN","DGO THRPT",105 ,0)
  6662    ;prompt s ort by:
  6663   "RTN","DGO THRPT",106 ,0)
  6664    ; 1) Pati ent Name
  6665   "RTN","DGO THRPT",107 ,0)
  6666    ; 2) Peri od
  6667   "RTN","DGO THRPT",108 ,0)
  6668    ; 3) Days  Remaining
  6669   "RTN","DGO THRPT",109 ,0)
  6670    I '$$SORT BY Q
  6671   "RTN","DGO THRPT",110 ,0)
  6672    ;
  6673   "RTN","DGO THRPT",111 ,0)
  6674    ;prompt f or device
  6675   "RTN","DGO THRPT",112 ,0)
  6676    W !
  6677   "RTN","DGO THRPT",113 ,0)
  6678    S ZTSAVE( "DGSORT(") =""
  6679   "RTN","DGO THRPT",114 ,0)
  6680    S X="OTHE R THAN HON ORABLE ACT IVE 90-DAY  PERIOD RE PORT"
  6681   "RTN","DGO THRPT",115 ,0)
  6682    D EN^XUTM DEVQ("STAR T^DGOTHRP2 ",X,.ZTSAV E)
  6683   "RTN","DGO THRPT",116 ,0)
  6684    D HOME^%Z IS
  6685   "RTN","DGO THRPT",117 ,0)
  6686    Q
  6687   "RTN","DGO THRPT",118 ,0)
  6688    ;
  6689   "RTN","DGO THRPT",119 ,0)
  6690   DATEBEG()  ;prompt fo r beginnin g date
  6691   "RTN","DGO THRPT",120 ,0)
  6692    N DGASK,D GDIRA,DGDI RB,DGDIRH, DGDIRO,DGB EGDT
  6693   "RTN","DGO THRPT",121 ,0)
  6694    W !
  6695   "RTN","DGO THRPT",122 ,0)
  6696    S DGDIRA= "Enter Beg inning Dat e"
  6697   "RTN","DGO THRPT",123 ,0)
  6698    S DGDIRB= ""
  6699   "RTN","DGO THRPT",124 ,0)
  6700    S DGDIRH= "^D HELP^D GOTHRPT(1) "
  6701   "RTN","DGO THRPT",125 ,0)
  6702    S DGBEGDT =$$FMADD^X LFDT(DT,-8 9)
  6703   "RTN","DGO THRPT",126 ,0)
  6704    S DGDIRO= "DO^"_DGBE GDT_":"_DT _":EX"
  6705   "RTN","DGO THRPT",127 ,0)
  6706    S DGASK=$ $ANSWER(DG DIRA,DGDIR B,DGDIRO,D GDIRH)
  6707   "RTN","DGO THRPT",128 ,0)
  6708    I DGASK>0  S DGSORT( "DGBEG")=D GASK
  6709   "RTN","DGO THRPT",129 ,0)
  6710    Q DGASK>0
  6711   "RTN","DGO THRPT",130 ,0)
  6712    ;
  6713   "RTN","DGO THRPT",131 ,0)
  6714   DATEEND()  ;prompt fo r ending d ate
  6715   "RTN","DGO THRPT",132 ,0)
  6716    N DGASK,D GDIRA,DGDI RB,DGDIRH, DGDIRO,DGD TEND
  6717   "RTN","DGO THRPT",133 ,0)
  6718    W !
  6719   "RTN","DGO THRPT",134 ,0)
  6720    S DGDIRA= "Enter End ing Date"
  6721   "RTN","DGO THRPT",135 ,0)
  6722    S DGDIRB= ""
  6723   "RTN","DGO THRPT",136 ,0)
  6724    S DGDIRH= "^D HELP^D GOTHRPT(2) "
  6725   "RTN","DGO THRPT",137 ,0)
  6726    S DGDTEND =$$FMADD^X LFDT(DGSOR T("DGBEG") ,364)
  6727   "RTN","DGO THRPT",138 ,0)
  6728    S DGDIRO= "DO^"_$$FM ADD^XLFDT( DT,1)_":"_ DGDTEND_": EX"
  6729   "RTN","DGO THRPT",139 ,0)
  6730    S DGASK=$ $ANSWER(DG DIRA,DGDIR B,DGDIRO,D GDIRH)
  6731   "RTN","DGO THRPT",140 ,0)
  6732    I DGASK>0  S DGSORT( "DGEND")=D GASK
  6733   "RTN","DGO THRPT",141 ,0)
  6734    Q DGASK>0
  6735   "RTN","DGO THRPT",142 ,0)
  6736    ;
  6737   "RTN","DGO THRPT",143 ,0)
  6738   SORTBY() ; prompt for  sort by
  6739   "RTN","DGO THRPT",144 ,0)
  6740    ; 1) Pati ent Name
  6741   "RTN","DGO THRPT",145 ,0)
  6742    ; 2) Peri od
  6743   "RTN","DGO THRPT",146 ,0)
  6744    ; 3) Days  Remaining
  6745   "RTN","DGO THRPT",147 ,0)
  6746    N DGASK,D GDIRA,DGDI RB,DGDIRH, DGDIRO
  6747   "RTN","DGO THRPT",148 ,0)
  6748    W !
  6749   "RTN","DGO THRPT",149 ,0)
  6750    S DGDIRA= "Print Rep ort Sorted  By"
  6751   "RTN","DGO THRPT",150 ,0)
  6752    S DGDIRB= ""
  6753   "RTN","DGO THRPT",151 ,0)
  6754    S DGDIRH= "Enter one  of the so rts select ions to re port on"
  6755   "RTN","DGO THRPT",152 ,0)
  6756    S DGDIRO= "SO^1:Sort  by Patien t Name;2:S ort by Per iod;3:Sort  by Days R emaining"
  6757   "RTN","DGO THRPT",153 ,0)
  6758    S DGASK=$ $ANSWER(DG DIRA,DGDIR B,DGDIRO,D GDIRH)
  6759   "RTN","DGO THRPT",154 ,0)
  6760    I DGASK>0  S DGSORT( "DGSRTBY") =DGASK_U_$ S(DGASK=1: "Sort by P atient Nam e",DGASK=2 :"Sort by  Period",DG ASK=3:"Sor t by Days  Remaining" ,1:"")
  6761   "RTN","DGO THRPT",155 ,0)
  6762    Q DGASK>0
  6763   "RTN","DGO THRPT",156 ,0)
  6764    ;
  6765   "RTN","DGO THRPT",157 ,0)
  6766   ANSWER(DGD IRA,DGDIRB ,DGDIR0,DG DIRH) ;
  6767   "RTN","DGO THRPT",158 ,0)
  6768    ; Input
  6769   "RTN","DGO THRPT",159 ,0)
  6770    ; DGDIR0  - DIR(0) s tring
  6771   "RTN","DGO THRPT",160 ,0)
  6772    ; DGDIRA  - DIR("A")  string
  6773   "RTN","DGO THRPT",161 ,0)
  6774    ; DGDIRB  - DIR("B")  string
  6775   "RTN","DGO THRPT",162 ,0)
  6776    ; DGDIRH  - DIR("?")  string
  6777   "RTN","DGO THRPT",163 ,0)
  6778    ; Output
  6779   "RTN","DGO THRPT",164 ,0)
  6780    ; Functio n Value -  Internal v alue retur ned from ^ DIR or -1  if user
  6781   "RTN","DGO THRPT",165 ,0)
  6782    ; up-arro ws, double  up-arrows  or the re ad times o ut.
  6783   "RTN","DGO THRPT",166 ,0)
  6784    N X,Y,Z,D IR,DIROUT, DIRUT,DTOU T,DUOUT
  6785   "RTN","DGO THRPT",167 ,0)
  6786    I $D(DGDI R0) S DIR( 0)=DGDIR0
  6787   "RTN","DGO THRPT",168 ,0)
  6788    I $D(DGDI RA) S DIR( "A")=DGDIR A
  6789   "RTN","DGO THRPT",169 ,0)
  6790    I $G(DGDI RB)]"" S D IR("B")=DG DIRB
  6791   "RTN","DGO THRPT",170 ,0)
  6792    I $D(DGDI RH) S DIR( "?")=DGDIR H,DIR("??" )=DGDIRH
  6793   "RTN","DGO THRPT",171 ,0)
  6794    D ^DIR
  6795   "RTN","DGO THRPT",172 ,0)
  6796    S Z=$S($D (DTOUT):-2 ,$D(DUOUT) :-1,$D(DIR OUT):-1,1: "")
  6797   "RTN","DGO THRPT",173 ,0)
  6798    I Z="" S  Z=$S(Y=-1: "",X="@":" @",1:$P(Y, U)) Q Z
  6799   "RTN","DGO THRPT",174 ,0)
  6800    I $D(DTOU T)!$D(DUOU T)!$D(DIRO UT) Q -1
  6801   "RTN","DGO THRPT",175 ,0)
  6802    Q $S(X="@ ":"@",1:$P (Y,U))
  6803   "RTN","DGO THRPT",176 ,0)
  6804    ;
  6805   "RTN","DGO THRPT",177 ,0)
  6806   HELP(DGSEL ) ;provide  extended  DIR("?") h elp text.
  6807   "RTN","DGO THRPT",178 ,0)
  6808    ;
  6809   "RTN","DGO THRPT",179 ,0)
  6810    ; Input:  DGSEL - pr ompt var f or help te xt word se lection
  6811   "RTN","DGO THRPT",180 ,0)
  6812    ; Output:  none
  6813   "RTN","DGO THRPT",181 ,0)
  6814    ;
  6815   "RTN","DGO THRPT",182 ,0)
  6816    I X'="?", X'="??" W  !,"  Not a  valid dat e.",!
  6817   "RTN","DGO THRPT",183 ,0)
  6818    N X S X=$ S(DGSEL=1: "earliest" ,1:"latest ")
  6819   "RTN","DGO THRPT",184 ,0)
  6820    I DGSEL=1  D
  6821   "RTN","DGO THRPT",185 ,0)
  6822    . W !,"   Beginning  Date canno t be more  than 90 da ys from to day."
  6823   "RTN","DGO THRPT",186 ,0)
  6824    . W !,"   Beginning  Date canno t be a fut ure date."
  6825   "RTN","DGO THRPT",187 ,0)
  6826    I DGSEL=2  D
  6827   "RTN","DGO THRPT",188 ,0)
  6828    . W !,"   Ending Dat e is today 's date +  1 day. The  latest en ding date  was "
  6829   "RTN","DGO THRPT",189 ,0)
  6830    . W !,"   calculated  by adding  364 days  from the B eginning D ate entere d by the u ser. "
  6831   "RTN","DGO THRPT",190 ,0)
  6832    W !!,"  E nter the " _X_" date  to include  in the re port."
  6833   "RTN","DGO THRPT",191 ,0)
  6834    W !,"  Pl ease enter  a date fr om the spe cified dat e range di splayed."
  6835   "RTN","DGO THRPT",192 ,0)
  6836    Q
  6837   "RTN","DGO THRPT",193 ,0)
  6838    ;
  6839   "RTN","DGO THRPT",194 ,0)
  6840    ;Entry po int DG OTH  STATISTIC AL REPORT
  6841   "RTN","DGO THRPT",195 ,0)
  6842    ;B3S2
  6843   "RTN","DGO THRPT",196 ,0)
  6844   ENSTAT ;
  6845   "RTN","DGO THRPT",197 ,0)
  6846    N DGFIRST   ;first O TH patient  DFN
  6847   "RTN","DGO THRPT",198 ,0)
  6848    N DGSORT    ;array o r report p arameters
  6849   "RTN","DGO THRPT",199 ,0)
  6850    N ZTSAVE    ;open ar ray refere nce of inp ut paramet ers used b y tasking
  6851   "RTN","DGO THRPT",200 ,0)
  6852    N ZTDESC    ;contain s the free -text desc ription of  your task  that you  passed to  the Progra m Interfac e.
  6853   "RTN","DGO THRPT",201 ,0)
  6854    N ZTQUEUE D ;backgro und execut ion
  6855   "RTN","DGO THRPT",202 ,0)
  6856    N ZTREQ     ;post-ex ecution
  6857   "RTN","DGO THRPT",203 ,0)
  6858    N ZTSTOP
  6859   "RTN","DGO THRPT",204 ,0)
  6860    N DGQMON
  6861   "RTN","DGO THRPT",205 ,0)
  6862    N DGDTRNG E ;statist ical repor t date ran ge
  6863   "RTN","DGO THRPT",206 ,0)
  6864    ;check fo r database
  6865   "RTN","DGO THRPT",207 ,0)
  6866    S DGFIRST =$P(+$O(^D GOTH(33,"B ","")),"," ) ;first O TH DFN
  6867   "RTN","DGO THRPT",208 ,0)
  6868    I 'DGFIRS T D  Q
  6869   "RTN","DGO THRPT",209 ,0)
  6870    . W !?2," >>> No Oth er Than Ho norable Pa tient Reco rd have be en found." ,*7
  6871   "RTN","DGO THRPT",210 ,0)
  6872    . I $$ANS WER^DGOTHR PT("Enter  RETURN to  continue", "","E")
  6873   "RTN","DGO THRPT",211 ,0)
  6874    ;
  6875   "RTN","DGO THRPT",212 ,0)
  6876    W @IOF
  6877   "RTN","DGO THRPT",213 ,0)
  6878    W "OTHER  THAN HONOR ABLE STATI STICAL REP ORT",!
  6879   "RTN","DGO THRPT",214 ,0)
  6880    W !,"This  option ge nerates a  statistica l report t hat will d isplay a l isting of"
  6881   "RTN","DGO THRPT",215 ,0)
  6882    W !,"Othe r Than Hon orable pat ients by:"
  6883   "RTN","DGO THRPT",216 ,0)
  6884    ;prompt f or fiscal  year
  6885   "RTN","DGO THRPT",217 ,0)
  6886    I '$$FISC AL,'$D(DGS ORT("DGFSC L")) Q
  6887   "RTN","DGO THRPT",218 ,0)
  6888    ;
  6889   "RTN","DGO THRPT",219 ,0)
  6890    ;prompt b y Quarter  or Fiscal  Year (All  Quarters)
  6891   "RTN","DGO THRPT",220 ,0)
  6892    I DGSORT( "DGFSCL")> 0,'$$QRTRA LL Q
  6893   "RTN","DGO THRPT",221 ,0)
  6894    ;
  6895   "RTN","DGO THRPT",222 ,0)
  6896    I 1234[$P (DGSORT("D GQTR"),U)  D  Q:DGQMO N<1
  6897   "RTN","DGO THRPT",223 ,0)
  6898    . ;prompt  month in  the quarte r or all q uarters
  6899   "RTN","DGO THRPT",224 ,0)
  6900    . S DGQMO N=$$MQ(.DG SORT)
  6901   "RTN","DGO THRPT",225 ,0)
  6902    . Q:DGQMO N<1
  6903   "RTN","DGO THRPT",226 ,0)
  6904    . D DTRAN GE
  6905   "RTN","DGO THRPT",227 ,0)
  6906    ;
  6907   "RTN","DGO THRPT",228 ,0)
  6908    ;prompt f or Summary  or Detail  if user s elect Fisc al Year (A ll Quarter s)
  6909   "RTN","DGO THRPT",229 ,0)
  6910    I 5[$P(DG SORT("DGQT R"),U) D F SCLYR
  6911   "RTN","DGO THRPT",230 ,0)
  6912    ;prompt f or device
  6913   "RTN","DGO THRPT",231 ,0)
  6914    W !
  6915   "RTN","DGO THRPT",232 ,0)
  6916    S ZTSAVE( "DGSORT(") =""
  6917   "RTN","DGO THRPT",233 ,0)
  6918    S X="OTHE R THAN HON ORABLE STA TISTICAL R EPORT"
  6919   "RTN","DGO THRPT",234 ,0)
  6920    D EN^XUTM DEVQ("STAR T^DGOTHRP3 ",X,.ZTSAV E)
  6921   "RTN","DGO THRPT",235 ,0)
  6922    D HOME^%Z IS
  6923   "RTN","DGO THRPT",236 ,0)
  6924    Q
  6925   "RTN","DGO THRPT",237 ,0)
  6926    ;
  6927   "RTN","DGO THRPT",238 ,0)
  6928   FISCAL() ; prompt for  fiscal ye ar
  6929   "RTN","DGO THRPT",239 ,0)
  6930    N DGASK,D GDIRA,DGDI RB,DGDIRH, DGDIRO,X
  6931   "RTN","DGO THRPT",240 ,0)
  6932    W !
  6933   "RTN","DGO THRPT",241 ,0)
  6934    S DGDIRA= "Enter Fis cal Year"
  6935   "RTN","DGO THRPT",242 ,0)
  6936    S DGDIRB= ""
  6937   "RTN","DGO THRPT",243 ,0)
  6938    S DGDIRH= "^D HELP^D GOTHRP3"
  6939   "RTN","DGO THRPT",244 ,0)
  6940    S DGDIRO= "DO^::AE"
  6941   "RTN","DGO THRPT",245 ,0)
  6942    S DGASK=$ $ANSWER(DG DIRA,DGDIR B,DGDIRO,D GDIRH)
  6943   "RTN","DGO THRPT",246 ,0)
  6944    I (+$E(DG ASK,4,5))! (+$E(DGASK ,6,7)) W !  S (X,DGAS K)="" D HE LP^DGOTHRP 3 D FISCAL
  6945   "RTN","DGO THRPT",247 ,0)
  6946    I DGASK>0  S DGSORT( "DGFSCL")= DGASK
  6947   "RTN","DGO THRPT",248 ,0)
  6948    Q DGASK>0
  6949   "RTN","DGO THRPT",249 ,0)
  6950    ;
  6951   "RTN","DGO THRPT",250 ,0)
  6952   QRTRALL()  ;prompt fo r statisti cal report  to print
  6953   "RTN","DGO THRPT",251 ,0)
  6954    ;
  6955   "RTN","DGO THRPT",252 ,0)
  6956    N DGASK,D GDIRA,DGDI RB,DGDIRH, DGDIRO,DGF YQ
  6957   "RTN","DGO THRPT",253 ,0)
  6958    S DGDIRA= "Select re porting pe riod "
  6959   "RTN","DGO THRPT",254 ,0)
  6960    S DGDIRB= ""
  6961   "RTN","DGO THRPT",255 ,0)
  6962    S DGDIRH= "Enter one  of the se lections t o report o n"
  6963   "RTN","DGO THRPT",256 ,0)
  6964    S DGDIRO= "SO^1:FY Q uarter 1 ( Oct-Nov-De c);2:FY Qu arter 2 (J an-Feb-Mar );3:FY Qua rter 3 (Ap r-May-Jun) ;4:FY Quar ter 4 (Jul -Aug-Sep); 5:Fiscal Y ear  (All  Quarters)"
  6965   "RTN","DGO THRPT",257 ,0)
  6966    S DGASK=$ $ANSWER^DG OTHRPT(DGD IRA,DGDIRB ,DGDIRO,DG DIRH)
  6967   "RTN","DGO THRPT",258 ,0)
  6968    S DGFYQ=$ S(DGASK=1: "FY Quarte r 1",DGASK =2:"FY Qua rter 2",DG ASK=3:"FY  Quarter 3" ,DGASK=4:" FY Quarter  4",DGASK= 5:"Fiscal  Year (All  Quarters)" ,1:"")
  6969   "RTN","DGO THRPT",259 ,0)
  6970    I DGASK>0  S DGSORT( "DGQTR")=D GASK_U_DGF YQ
  6971   "RTN","DGO THRPT",260 ,0)
  6972    Q DGASK>0
  6973   "RTN","DGO THRPT",261 ,0)
  6974    ;
  6975   "RTN","DGO THRPT",262 ,0)
  6976   MQ(DGSORT)  ;prompt m onth in th e quarter
  6977   "RTN","DGO THRPT",263 ,0)
  6978    ;
  6979   "RTN","DGO THRPT",264 ,0)
  6980    N DGASK,D GDIRA,DGDI RB,DGDIRH, DGDIRO,DGF YQ,DGMIN,D GMAX,I,DGM ON,DGCNT
  6981   "RTN","DGO THRPT",265 ,0)
  6982    S DGDIRA= "Select th e month of  the Quart er or All"
  6983   "RTN","DGO THRPT",266 ,0)
  6984    S DGDIRB= ""
  6985   "RTN","DGO THRPT",267 ,0)
  6986    S DGDIRH= "Enter one  of the se lections t o report o n"
  6987   "RTN","DGO THRPT",268 ,0)
  6988    S DGMIN=$ E($P($P($T (DATES+$P( DGSORT("DG QTR"),U)), ";;",2),"^ "),1,2)
  6989   "RTN","DGO THRPT",269 ,0)
  6990    S DGMAX=$ E($P($P($T (DATES+$P( DGSORT("DG QTR"),U)), ";;",2),"^ ",2),1,2)
  6991   "RTN","DGO THRPT",270 ,0)
  6992    S DGCNT=0
  6993   "RTN","DGO THRPT",271 ,0)
  6994    F I=DGMIN :1:DGMAX D
  6995   "RTN","DGO THRPT",272 ,0)
  6996    . S DGCNT =DGCNT+1
  6997   "RTN","DGO THRPT",273 ,0)
  6998    . S DGMON (DGCNT)=$P ($P($T(MON AME+I^DGOT HRP3),";;" ,2),"^",2) _U_I
  6999   "RTN","DGO THRPT",274 ,0)
  7000    S DGDIRO= "SO^1:"_$P (DGMON(1), U)_";2:"_$ P(DGMON(2) ,U)_";3:"_ $P(DGMON(3 ),U)_";4:A ll Months  in the Qua rter"
  7001   "RTN","DGO THRPT",275 ,0)
  7002    S DGASK=$ $ANSWER^DG OTHRPT(DGD IRA,DGDIRB ,DGDIRO,DG DIRH)
  7003   "RTN","DGO THRPT",276 ,0)
  7004    I DGASK>0  D
  7005   "RTN","DGO THRPT",277 ,0)
  7006    . S DGSOR T("DGMON") =DGASK_U_$ S(123[DGAS K:DGMON(DG ASK),1:"Al l Months i n the Quar ter")
  7007   "RTN","DGO THRPT",278 ,0)
  7008    . I 4[DGA SK D
  7009   "RTN","DGO THRPT",279 ,0)
  7010    . . F I=1 :1:3 S DGS ORT("DGMON ",$P(DGMON (I),U,2))= DGMON(I)
  7011   "RTN","DGO THRPT",280 ,0)
  7012    Q DGASK>0
  7013   "RTN","DGO THRPT",281 ,0)
  7014    ;
  7015   "RTN","DGO THRPT",282 ,0)
  7016   DTRANGE ;c alculate m onthly dat e range
  7017   "RTN","DGO THRPT",283 ,0)
  7018    ;print by  monthly
  7019   "RTN","DGO THRPT",284 ,0)
  7020    N I
  7021   "RTN","DGO THRPT",285 ,0)
  7022    I 123[$P( DGSORT("DG MON"),U) D
  7023   "RTN","DGO THRPT",286 ,0)
  7024    . S DGMON =$E(DGSORT ("DGFSCL") ,1,3)-$S($ P(DGSORT(" DGQTR"),U) =1:1,1:0)
  7025   "RTN","DGO THRPT",287 ,0)
  7026    . S DGMON =DGMON_$S( $P(DGSORT( "DGMON"),U ,3)<=9:"0" _$P(DGSORT ("DGMON"), U,3),1:$P( DGSORT("DG MON"),U,3) )_"00"
  7027   "RTN","DGO THRPT",288 ,0)
  7028    . S DGMON =$$MONTH(D GMON)
  7029   "RTN","DGO THRPT",289 ,0)
  7030    . S DGSOR T("DGBEG") =$P(DGMON, U)
  7031   "RTN","DGO THRPT",290 ,0)
  7032    . S DGSOR T("DGEND") =$P(DGMON, U,2)
  7033   "RTN","DGO THRPT",291 ,0)
  7034    E  D
  7035   "RTN","DGO THRPT",292 ,0)
  7036    . ;all mo nth in the  quarter r ange
  7037   "RTN","DGO THRPT",293 ,0)
  7038    . S DGSOR T("DGBEG") =$E(DGSORT ("DGFSCL") ,1,3)-$S($ P(DGSORT(" DGQTR"),U) =1:1,1:0)_ $P($P($T(D ATES+$P(DG SORT("DGQT R"),U)),"; ;",2),"^")
  7039   "RTN","DGO THRPT",294 ,0)
  7040    . S DGSOR T("DGEND") =$E(DGSORT ("DGFSCL") ,1,3)-$S($ P(DGSORT(" DGQTR"),U) =1:1,1:0)_ $P($P($T(D ATES+$P(DG SORT("DGQT R"),U)),"; ;",2),"^", 2)
  7041   "RTN","DGO THRPT",295 ,0)
  7042    D MSG(.DG SORT)
  7043   "RTN","DGO THRPT",296 ,0)
  7044    ;
  7045   "RTN","DGO THRPT",297 ,0)
  7046    Q
  7047   "RTN","DGO THRPT",298 ,0)
  7048    ;
  7049   "RTN","DGO THRPT",299 ,0)
  7050   CALRNGE(DG SORT,Q,M)  ;calculate  date rang e by month
  7051   "RTN","DGO THRPT",300 ,0)
  7052    I 4[$P(DG SORT("DGMO N"),U) D
  7053   "RTN","DGO THRPT",301 ,0)
  7054    . S DGMON =$E(DGSORT ("DGFSCL") ,1,3)-$S($ P(DGSORT(" DGQTR"),U) =1:1,1:0)
  7055   "RTN","DGO THRPT",302 ,0)
  7056    . S DGMON =DGMON_$S( $P(DGSORT( "DGMON",M) ,U,2)<=9:" 0"_$P(DGSO RT("DGMON" ,M),U,2),1 :$P(DGSORT ("DGMON",M ),U,2))_"0 0"
  7057   "RTN","DGO THRPT",303 ,0)
  7058    I 5[$P(DG SORT("DGMO N"),U) D
  7059   "RTN","DGO THRPT",304 ,0)
  7060    . S DGMON =$E(DGSORT ("DGFSCL") ,1,3)-$S($ G(Q)=1:1,1 :0)
  7061   "RTN","DGO THRPT",305 ,0)
  7062    . S DGMON =DGMON_$S( $P(DGSORT( "DGMON",Q, M),U,2)<=9 :"0"_$P(DG SORT("DGMO N",Q,M),U, 2),1:$P(DG SORT("DGMO N",Q,M),U, 2))_"00"
  7063   "RTN","DGO THRPT",306 ,0)
  7064    S DGMON=$ $MONTH(DGM ON)
  7065   "RTN","DGO THRPT",307 ,0)
  7066    Q DGMON
  7067   "RTN","DGO THRPT",308 ,0)
  7068    ;
  7069   "RTN","DGO THRPT",309 ,0)
  7070   FSCLYR ;ca lculate fi scal year  date range
  7071   "RTN","DGO THRPT",310 ,0)
  7072    N I,II,DG MIN,DGMAX
  7073   "RTN","DGO THRPT",311 ,0)
  7074    S DGSORT( "DGBEG")=$ E(DGSORT(" DGFSCL"),1 ,3)-1_$P($ P($T(DATES +1),";;",2 ),"^")
  7075   "RTN","DGO THRPT",312 ,0)
  7076    S DGSORT( "DGEND")=$ E(DGSORT(" DGFSCL"),1 ,3)_$P($P( $T(DATES+4 ),";;",2), "^",2)
  7077   "RTN","DGO THRPT",313 ,0)
  7078    ;create S  DGSORT("D GMON") arr ay for the  whole fis cal year
  7079   "RTN","DGO THRPT",314 ,0)
  7080    S DGSORT( "DGMON")=D GSORT("DGQ TR")
  7081   "RTN","DGO THRPT",315 ,0)
  7082    F I=1:1:4  D
  7083   "RTN","DGO THRPT",316 ,0)
  7084    . K DGSOR T("DGQTR")
  7085   "RTN","DGO THRPT",317 ,0)
  7086    . S DGSOR T("DGQTR") =I
  7087   "RTN","DGO THRPT",318 ,0)
  7088    . S DGMIN =$E($P($P( $T(DATES+$ P(DGSORT(" DGQTR"),U) ),";;",2), "^"),1,2)
  7089   "RTN","DGO THRPT",319 ,0)
  7090    . S DGMAX =$E($P($P( $T(DATES+$ P(DGSORT(" DGQTR"),U) ),";;",2), "^",2),1,2 )
  7091   "RTN","DGO THRPT",320 ,0)
  7092    . F II=DG MIN:1:DGMA X S DGSORT ("DGMON",I ,II)=$P($P ($T(MONAME +II^DGOTHR P3),";;",2 ),"^",2)_U _II
  7093   "RTN","DGO THRPT",321 ,0)
  7094    D MSG(.DG SORT)
  7095   "RTN","DGO THRPT",322 ,0)
  7096    Q
  7097   "RTN","DGO THRPT",323 ,0)
  7098    ;
  7099   "RTN","DGO THRPT",324 ,0)
  7100   MSG(DGSORT ) ;
  7101   "RTN","DGO THRPT",325 ,0)
  7102    S DGDTRNG E=$$FMTE^X LFDT(DGSOR T("DGBEG") ,5)_" TO " _$$FMTE^XL FDT(DGSORT ("DGEND"), 5)
  7103   "RTN","DGO THRPT",326 ,0)
  7104    W !!,"Sta tistical D ate Range  Selected:  ",$$FMTE^X LFDT(DGSOR T("DGBEG") ,1)," to " ,$$FMTE^XL FDT(DGSORT ("DGEND"), 1)
  7105   "RTN","DGO THRPT",327 ,0)
  7106    Q
  7107   "RTN","DGO THRPT",328 ,0)
  7108    ;
  7109   "RTN","DGO THRPT",329 ,0)
  7110   DATES ;sto re date ra nges for e ach quarte r
  7111   "RTN","DGO THRPT",330 ,0)
  7112    ;;1001^12 31
  7113   "RTN","DGO THRPT",331 ,0)
  7114    ;;0101^03 31
  7115   "RTN","DGO THRPT",332 ,0)
  7116    ;;0401^06 30
  7117   "RTN","DGO THRPT",333 ,0)
  7118    ;;0701^09 30
  7119   "RTN","DGO THRPT",334 ,0)
  7120    Q
  7121   "RTN","DGO THRPT",335 ,0)
  7122    ;
  7123   "RTN","DGO THRPT",336 ,0)
  7124   MONTH(DGRR DT) ; Pass  in a date  (default  = today's  date)
  7125   "RTN","DGO THRPT",337 ,0)
  7126    ; this fu nction ret urns the f irst and l ast dates  of the mon th
  7127   "RTN","DGO THRPT",338 ,0)
  7128    N DGRRMST ,DGRRMND
  7129   "RTN","DGO THRPT",339 ,0)
  7130    S:'$D(DGR RDT) DGRRD T=DT
  7131   "RTN","DGO THRPT",340 ,0)
  7132    S DGRRMST =$E(DGRRDT ,1,5)_"01"
  7133   "RTN","DGO THRPT",341 ,0)
  7134    S DGRRMND =$$SCH^XLF DT("1M(1)" ,DGRRMST)\ 1
  7135   "RTN","DGO THRPT",342 ,0)
  7136    Q DGRRMST _U_DGRRMND
  7137   "RTN","DGO THRPT",343 ,0)
  7138    ;
  7139   "RTN","DGO THRPT",344 ,0)
  7140   FY(DGRRDT)  ; Pass in  a date (d efault = t oday's dat e),
  7141   "RTN","DGO THRPT",345 ,0)
  7142    ; and thi s function  returns w hat FY we  are in,
  7143   "RTN","DGO THRPT",346 ,0)
  7144    ; followe d by the F Y start da te and FY  end date.
  7145   "RTN","DGO THRPT",347 ,0)
  7146    ; ie. S X =$$FY^DGOT HST(305020 8) results  in X="FY  2005^30410 00^3051000 "
  7147   "RTN","DGO THRPT",348 ,0)
  7148    N DGRRST, DGRRND
  7149   "RTN","DGO THRPT",349 ,0)
  7150    S:'$D(DGR RDT) DGRRD T=DT
  7151   "RTN","DGO THRPT",350 ,0)
  7152    S DGRRST= $E(DGRRDT, 1,3)-($E(D GRRDT,4,5) <10)_"1000 "
  7153   "RTN","DGO THRPT",351 ,0)
  7154    S DGRRND= $E(DGRRST, 1,3)+1_"10 00"
  7155   "RTN","DGO THRPT",352 ,0)
  7156    Q "FY "_( 1701+$E(DG RRST,1,3)) _U_DGRRST_ U_DGRRND
  7157   "RTN","DGO THRPT",353 ,0)
  7158    ;
  7159   "RTN","DGO THUT1")
  7160   0^19^B2466 3755
  7161   "RTN","DGO THUT1",1,0 )
  7162   DGOTHUT1 ; SHRPE/YMG  - OTHD (OT HER THAN H ONORABLE D ISCHARGE)  APIs ; 03/ 12/19
  7163   "RTN","DGO THUT1",2,0 )
  7164    ;;5.3;Reg istration; **952**;Au g 13, 1993 ;Build 68
  7165   "RTN","DGO THUT1",3,0 )
  7166    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  7167   "RTN","DGO THUT1",4,0 )
  7168    ;
  7169   "RTN","DGO THUT1",5,0 )
  7170    Q
  7171   "RTN","DGO THUT1",6,0 )
  7172    ;
  7173   "RTN","DGO THUT1",7,0 )
  7174   LASTPRD(DG IEN33) ; f ind last 3 65 and 90  day period s
  7175   "RTN","DGO THUT1",8,0 )
  7176    ;
  7177   "RTN","DGO THUT1",9,0 )
  7178    ; DGIEN33  - file 33  ien
  7179   "RTN","DGO THUT1",10, 0)
  7180    ;
  7181   "RTN","DGO THUT1",11, 0)
  7182    ; returns  the follo wing strin g delimite d by "^" ( if data ca n't be fou nd, corres ponding pi ece is set  to 0):
  7183   "RTN","DGO THUT1",12, 0)
  7184    ;  p1 = #  of the la st 365 day  period
  7185   "RTN","DGO THUT1",13, 0)
  7186    ;  p2 = i en (in sub -file 33.0 1) of the  last 365 d ay period
  7187   "RTN","DGO THUT1",14, 0)
  7188    ;  p3 = #  of the la st 90 day  period
  7189   "RTN","DGO THUT1",15, 0)
  7190    ;  p4 = i en (in sub -file 33.1 1) of the  last 90 da y period
  7191   "RTN","DGO THUT1",16, 0)
  7192    ;
  7193   "RTN","DGO THUT1",17, 0)
  7194    N IEN3301 ,IEN3311,L ST365,LST9 0,RES
  7195   "RTN","DGO THUT1",18, 0)
  7196    S RES="0^ 0^0^0" I $ G(DGIEN33) >0,$D(^DGO TH(33,DGIE N33))>0 D
  7197   "RTN","DGO THUT1",19, 0)
  7198    .S LST365 =+$O(^DGOT H(33,DGIEN 33,1,"B"," "),-1),IEN 3301=+$O(^ DGOTH(33,D GIEN33,1," B",LST365, ""))
  7199   "RTN","DGO THUT1",20, 0)
  7200    .I IEN330 1>0 D
  7201   "RTN","DGO THUT1",21, 0)
  7202    ..S $P(RE S,U)=LST36 5,$P(RES,U ,2)=IEN330 1
  7203   "RTN","DGO THUT1",22, 0)
  7204    ..S LST90 =+$O(^DGOT H(33,DGIEN 33,1,IEN33 01,1,"B"," "),-1)
  7205   "RTN","DGO THUT1",23, 0)
  7206    ..S IEN33 11=+$O(^DG OTH(33,DGI EN33,1,IEN 3301,1,"B" ,LST90,"") )
  7207   "RTN","DGO THUT1",24, 0)
  7208    ..S $P(RE S,U,3)=LST 90,$P(RES, U,4)=IEN33 11
  7209   "RTN","DGO THUT1",25, 0)
  7210    ..Q
  7211   "RTN","DGO THUT1",26, 0)
  7212    .Q
  7213   "RTN","DGO THUT1",27, 0)
  7214    Q RES
  7215   "RTN","DGO THUT1",28, 0)
  7216    ;
  7217   "RTN","DGO THUT1",29, 0)
  7218   GET90DT(DG IEN33,DGIE N3301,DGIE N3311) ; r eturn date s info for  a given 9 0 day peri od
  7219   "RTN","DGO THUT1",30, 0)
  7220    ;
  7221   "RTN","DGO THUT1",31, 0)
  7222    ; DGIEN33    - file  33 ien
  7223   "RTN","DGO THUT1",32, 0)
  7224    ; DGIEN33 01 - sub-f ile 33.01  ien
  7225   "RTN","DGO THUT1",33, 0)
  7226    ; DGIEN33 11 - sub-f ile 33.11  ien
  7227   "RTN","DGO THUT1",34, 0)
  7228    ;
  7229   "RTN","DGO THUT1",35, 0)
  7230    ; returns  the follo wing strin g delimite d by "^" ( if data ca n't be fou nd, corres ponding pi ece is set  to 0):
  7231   "RTN","DGO THUT1",36, 0)
  7232    ;  p1 = s tart date  (internal  FM format)
  7233   "RTN","DGO THUT1",37, 0)
  7234    ;  p2 = e nd date (i nternal FM  format)
  7235   "RTN","DGO THUT1",38, 0)
  7236    ;  p3 = d ays left i n this per iod
  7237   "RTN","DGO THUT1",39, 0)
  7238    ;
  7239   "RTN","DGO THUT1",40, 0)
  7240    N DAYS,ED T,SDT
  7241   "RTN","DGO THUT1",41, 0)
  7242    S (DAYS,E DT)=0
  7243   "RTN","DGO THUT1",42, 0)
  7244    S SDT=+$$ GET1^DIQ(3 3.11,DGIEN 3311_","_D GIEN3301_" ,"_DGIEN33 _",",.02," I")
  7245   "RTN","DGO THUT1",43, 0)
  7246    I SDT D
  7247   "RTN","DGO THUT1",44, 0)
  7248    .S EDT=$$ FMADD^XLFD T(SDT,90), DAYS=$$FMD IFF^XLFDT( EDT,DT,1)
  7249   "RTN","DGO THUT1",45, 0)
  7250    .S DAYS=$ S(DAYS<0:0 ,DAYS>90:9 0,1:DAYS)
  7251   "RTN","DGO THUT1",46, 0)
  7252    .Q
  7253   "RTN","DGO THUT1",47, 0)
  7254    Q SDT_U_E DT_U_DAYS
  7255   "RTN","DGO THUT1",48, 0)
  7256    ;
  7257   "RTN","DGO THUT1",49, 0)
  7258   GET365DT(D GIEN33,DGI EN3301) ;  return dat es info fo r a given  365 day pe riod
  7259   "RTN","DGO THUT1",50, 0)
  7260    ;
  7261   "RTN","DGO THUT1",51, 0)
  7262    ; DGIEN33    - file  33 ien
  7263   "RTN","DGO THUT1",52, 0)
  7264    ; DGIEN33 01 - sub-f ile 33.01  ien
  7265   "RTN","DGO THUT1",53, 0)
  7266    ;
  7267   "RTN","DGO THUT1",54, 0)
  7268    ; returns  the follo wing strin g delimite d by "^" ( if data ca n't be fou nd, corres ponding pi ece is set  to 0):
  7269   "RTN","DGO THUT1",55, 0)
  7270    ;  p1 = s tart date  (internal  FM format)
  7271   "RTN","DGO THUT1",56, 0)
  7272    ;  p2 = e nd date (i nternal FM  format)
  7273   "RTN","DGO THUT1",57, 0)
  7274    ;
  7275   "RTN","DGO THUT1",58, 0)
  7276    N EDT,SDT
  7277   "RTN","DGO THUT1",59, 0)
  7278    S EDT=0
  7279   "RTN","DGO THUT1",60, 0)
  7280    S SDT=+$$ GET1^DIQ(3 3.01,DGIEN 3301_","_D GIEN33_"," ,.02,"I")
  7281   "RTN","DGO THUT1",61, 0)
  7282    I SDT S E DT=$$FMADD ^XLFDT(SDT ,365)
  7283   "RTN","DGO THUT1",62, 0)
  7284    Q SDT_U_E DT
  7285   "RTN","DGO THUT1",63, 0)
  7286    ;
  7287   "RTN","DGO THUT1",64, 0)
  7288   LOCK(DGIEN 33) ; lock  entry in  file 33
  7289   "RTN","DGO THUT1",65, 0)
  7290    ;
  7291   "RTN","DGO THUT1",66, 0)
  7292    ; DGIEN33  - file 33  ien of th e entry to  lock
  7293   "RTN","DGO THUT1",67, 0)
  7294    ;
  7295   "RTN","DGO THUT1",68, 0)
  7296    ; returns  1 if lock  was succe ssful, 0 o therwise
  7297   "RTN","DGO THUT1",69, 0)
  7298    ;
  7299   "RTN","DGO THUT1",70, 0)
  7300    N RES
  7301   "RTN","DGO THUT1",71, 0)
  7302    S RES=0
  7303   "RTN","DGO THUT1",72, 0)
  7304    I +$G(DGI EN33) L +^ DGOTH(33,D GIEN33):5  S RES=$T
  7305   "RTN","DGO THUT1",73, 0)
  7306    Q RES
  7307   "RTN","DGO THUT1",74, 0)
  7308    ;
  7309   "RTN","DGO THUT1",75, 0)
  7310   UNLOCK(DGI EN33) ; un lock entry  in file 3 3
  7311   "RTN","DGO THUT1",76, 0)
  7312    ;
  7313   "RTN","DGO THUT1",77, 0)
  7314    ; DGIEN33  - file 33  ien of th e entry to  unlock
  7315   "RTN","DGO THUT1",78, 0)
  7316    ;
  7317   "RTN","DGO THUT1",79, 0)
  7318    I +$G(DGI EN33) L -^ DGOTH(33,D GIEN33)
  7319   "RTN","DGO THUT1",80, 0)
  7320    Q
  7321   "RTN","DGO THUT1",81, 0)
  7322    ;
  7323   "RTN","DGO THUT1",82, 0)
  7324   FILEPRD(DG DFN,DATAST R) ; file  data into  file 33
  7325   "RTN","DGO THUT1",83, 0)
  7326    ;
  7327   "RTN","DGO THUT1",84, 0)
  7328    ; creates  new entri es in sub- files 33.0 1 and/or 3 3.11 if ne cessary, t hen files  data passe d in DATAS TR
  7329   "RTN","DGO THUT1",85, 0)
  7330    ; will on ly file da ta into an  existing  top level  entry in f ile 33
  7331   "RTN","DGO THUT1",86, 0)
  7332    ;
  7333   "RTN","DGO THUT1",87, 0)
  7334    ; DGDFN -  patient D FN
  7335   "RTN","DGO THUT1",88, 0)
  7336    ; DATASTR  - string  delimited  by "^", as  follows:
  7337   "RTN","DGO THUT1",89, 0)
  7338    ;  p1 = 3 65 days pe riod # to  be filed -  required
  7339   "RTN","DGO THUT1",90, 0)
  7340    ;  p2 = 9 0 days per iod # to b e filed -  required
  7341   "RTN","DGO THUT1",91, 0)
  7342    ;  p3 = d ate reques t submitte d
  7343   "RTN","DGO THUT1",92, 0)
  7344    ;  p4 = a uthorized  by (name)
  7345   "RTN","DGO THUT1",93, 0)
  7346    ;  p5 = a uthorizati on receive d date
  7347   "RTN","DGO THUT1",94, 0)
  7348    ;  p6 = s tart date  of this 90  days peri od
  7349   "RTN","DGO THUT1",95, 0)
  7350    ;  p7 = a uthorizati on comment
  7351   "RTN","DGO THUT1",96, 0)
  7352    ;  p8 = e ntered by  (name) - r equired
  7353   "RTN","DGO THUT1",97, 0)
  7354    ;  p9 = f acility (f ile 4 ien)  - require d
  7355   "RTN","DGO THUT1",98, 0)
  7356    ;
  7357   "RTN","DGO THUT1",99, 0)
  7358    ; returns  1 on succ ess, "0 ^  [error mes sage]" on  failure
  7359   "RTN","DGO THUT1",100 ,0)
  7360    ;
  7361   "RTN","DGO THUT1",101 ,0)
  7362    N DGERR,D GFDA,IEN33 ,IEN365,IE N90,IENARY ,IENS,NUM3 65,NUM90,R ES
  7363   "RTN","DGO THUT1",102 ,0)
  7364    ;
  7365   "RTN","DGO THUT1",103 ,0)
  7366    S RES=1
  7367   "RTN","DGO THUT1",104 ,0)
  7368    I +$G(DGD FN)'>0 S R ES="0^Inva lid DFN" G  FILEPRDX
  7369   "RTN","DGO THUT1",105 ,0)
  7370    ; get fil e 33 ien t o file dat a into
  7371   "RTN","DGO THUT1",106 ,0)
  7372    S IEN33=+ $O(^DGOTH( 33,"B",DGD FN,"")) I  IEN33'>0 S  RES="0^Un able to fi nd an entr y in file  33 for thi s patient"  G FILEPRD X
  7373   "RTN","DGO THUT1",107 ,0)
  7374    ; try to  lock entry
  7375   "RTN","DGO THUT1",108 ,0)
  7376    I '$$LOCK (IEN33) S  RES="0^Una ble to loc k entry in  file 33 ( ien = "_IE N33_")" G  FILEPRDX
  7377   "RTN","DGO THUT1",109 ,0)
  7378    ; get sub -file 33.0 1 ien, cre ate new en try if nec essary
  7379   "RTN","DGO THUT1",110 ,0)
  7380    S NUM365= +$P(DATAST R,U) I NUM 365'>0 S R ES="0^Inva lid 365 da y period n umber" G F ILEPRDX
  7381   "RTN","DGO THUT1",111 ,0)
  7382    S IEN365= +$O(^DGOTH (33,IEN33, 1,"B",NUM3 65,"")) I  IEN365'>0  D
  7383   "RTN","DGO THUT1",112 ,0)
  7384    .; no exi sting entr y for this  365 day p eriod - cr eate a new  one
  7385   "RTN","DGO THUT1",113 ,0)
  7386    .S IENS=" +1,"_IEN33 _","
  7387   "RTN","DGO THUT1",114 ,0)
  7388    .S DGFDA( 33.01,IENS ,.01)=NUM3 65
  7389   "RTN","DGO THUT1",115 ,0)
  7390    .I $P(DAT ASTR,U,6)> 0 S DGFDA( 33.01,IENS ,.02)=$P(D ATASTR,U,6 ) ; make s tart date  of new 365  day perio d the same  as starti ng date of  90 day pe riod we're  filing
  7391   "RTN","DGO THUT1",116 ,0)
  7392    .D UPDATE ^DIE(,"DGF DA","IENAR Y","DGERR" )
  7393   "RTN","DGO THUT1",117 ,0)
  7394    .S IEN365 =+$G(IENAR Y(1))
  7395   "RTN","DGO THUT1",118 ,0)
  7396    .K DGFDA, IENARY
  7397   "RTN","DGO THUT1",119 ,0)
  7398    .Q
  7399   "RTN","DGO THUT1",120 ,0)
  7400    I $D(DGER R) S RES=" 0^"_$G(DGE RR("DIERR" ,1,"TEXT", 1)) G FILE PRDX
  7401   "RTN","DGO THUT1",121 ,0)
  7402    ; get sub -file 33.1 1 ien, cre ate new en try if nec essary
  7403   "RTN","DGO THUT1",122 ,0)
  7404    S NUM90=+ $P(DATASTR ,U,2) I NU M90'>0 S R ES="0^Inva lid 90 day  period nu mber" G FI LEPRDX
  7405   "RTN","DGO THUT1",123 ,0)
  7406    S IEN90=+ $O(^DGOTH( 33,IEN33,1 ,IEN365,1, "B",NUM90, "")) I IEN 90'>0 D
  7407   "RTN","DGO THUT1",124 ,0)
  7408    .; no exi sting entr y for this  90 day pe riod - cre ate a new  one
  7409   "RTN","DGO THUT1",125 ,0)
  7410    .S IENS=" +1,"_IEN36 5_","_IEN3 3_","
  7411   "RTN","DGO THUT1",126 ,0)
  7412    .S DGFDA( 33.11,IENS ,.01)=NUM9 0
  7413   "RTN","DGO THUT1",127 ,0)
  7414    .D UPDATE ^DIE(,"DGF DA","IENAR Y","DGERR" )
  7415   "RTN","DGO THUT1",128 ,0)
  7416    .S IEN90= +$G(IENARY (1))
  7417   "RTN","DGO THUT1",129 ,0)
  7418    .K DGFDA, IENARY
  7419   "RTN","DGO THUT1",130 ,0)
  7420    .Q
  7421   "RTN","DGO THUT1",131 ,0)
  7422    I $D(DGER R) S RES=" 0^"_$G(DGE RR("DIERR" ,1,"TEXT", 1)) G FILE PRDX
  7423   "RTN","DGO THUT1",132 ,0)
  7424    ; file da ta
  7425   "RTN","DGO THUT1",133 ,0)
  7426    S IENS=IE N90_","_IE N365_","_I EN33_","
  7427   "RTN","DGO THUT1",134 ,0)
  7428    I +$P(DAT ASTR,U,6)  S DGFDA(33 .11,IENS,. 02)=$P(DAT ASTR,U,6)
  7429   "RTN","DGO THUT1",135 ,0)
  7430    I +$P(DAT ASTR,U,5)  D
  7431   "RTN","DGO THUT1",136 ,0)
  7432    .S DGFDA( 33.11,IENS ,.03)=$E($ P(DATASTR, U,8),1,60)
  7433   "RTN","DGO THUT1",137 ,0)
  7434    .S DGFDA( 33.11,IENS ,.04)=$P(D ATASTR,U,5 )
  7435   "RTN","DGO THUT1",138 ,0)
  7436    .Q
  7437   "RTN","DGO THUT1",139 ,0)
  7438    S DGFDA(3 3.11,IENS, .05)=$E($P (DATASTR,U ,8),1,60)
  7439   "RTN","DGO THUT1",140 ,0)
  7440    S DGFDA(3 3.11,IENS, .06)=$$NOW ^XLFDT()
  7441   "RTN","DGO THUT1",141 ,0)
  7442    I $P(DATA STR,U,4)'= "" S DGFDA (33.11,IEN S,.07)=$E( $P(DATASTR ,U,4),1,60 )
  7443   "RTN","DGO THUT1",142 ,0)
  7444    S DGFDA(3 3.11,IENS, .08)=$P(DA TASTR,U,9)
  7445   "RTN","DGO THUT1",143 ,0)
  7446    I $P(DATA STR,U,7)'= "" S DGFDA (33.11,IEN S,.09)=$E( $P(DATASTR ,U,7),1,60 )
  7447   "RTN","DGO THUT1",144 ,0)
  7448    I +$P(DAT ASTR,U,3)  S DGFDA(33 .11,IENS,. 1)=$P(DATA STR,U,3)
  7449   "RTN","DGO THUT1",145 ,0)
  7450    D FILE^DI E(,"DGFDA" ,"DGERR")
  7451   "RTN","DGO THUT1",146 ,0)
  7452    I $D(DGER R) S RES=" 0^"_$G(DGE RR("DIERR" ,1,"TEXT", 1))
  7453   "RTN","DGO THUT1",147 ,0)
  7454    ;
  7455   "RTN","DGO THUT1",148 ,0)
  7456   FILEPRDX ;  exit poin t
  7457   "RTN","DGO THUT1",149 ,0)
  7458    ; unlock  entry
  7459   "RTN","DGO THUT1",150 ,0)
  7460    D UNLOCK( IEN33)
  7461   "RTN","DGO THUT1",151 ,0)
  7462    Q RES
  7463   "RTN","DGR P7")
  7464   0^15^B2137 0530
  7465   "RTN","DGR P7",1,0)
  7466   DGRP7 ;ALB /MRL,CKN,E RC - REGIS TRATION SC REEN 7/ELI GIBILITY I NFORMATION  ;7/25/06  12:06pm
  7467   "RTN","DGR P7",2,0)
  7468    ;;5.3;Reg istration; **528,653, 688,842,95 2**;Aug 13 , 1993;Bui ld 68
  7469   "RTN","DGR P7",3,0)
  7470    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  7471   "RTN","DGR P7",4,0)
  7472    ;
  7473   "RTN","DGR P7",5,0)
  7474    N DGCASH, DGMBCK,DGO THMSG,DGPR VSEL
  7475   "RTN","DGR P7",6,0)
  7476    ;DG*5.3*9 52 add .55  into DRPG  array
  7477   "RTN","DGR P7",7,0)
  7478    S DGRPS=7  D H^DGRPU  F I=0,.29 ,.3,.31,.3 2,.321,.36 ,.362,.385 ,.55,"TYPE ","VET" S  DGRP(I)=$S ($D(^DPT(D FN,I)):^(I ),1:"")
  7479   "RTN","DGR P7",8,0)
  7480    S (DGRPW, Z)=1 D WW^ DGRPV W "        Pati ent Type:  " S DGRPX= DGRP("TYPE "),Z=$S($D (^DG(391,+ DGRPX,0)): $P(^(0),"^ ",1),1:DGR PU),Z1=34  D WW1^DGRP V W "Veter an: " S DG RPX=DGRP(" VET"),(X,Z 1)=1 D YN
  7481   "RTN","DGR P7",9,0)
  7482    W !?9,"Sv c Connecte d: " S DGR PX=DGRP(.3 ),X=1,Z1=3 1,DGNA=$S( $P(DGRP("V ET"),"^",1 )="Y":0,1: 1) D YN2 W  "SC Perce nt: " W:$E (Z)'="Y" " N/A" I $E( Z)="Y" D
  7483   "RTN","DGR P7",10,0)
  7484    .S X=$P(D GRPX,"^",2 ) W $S(X=" ":"UNANSWE RED",1:+X_ "%")
  7485   "RTN","DGR P7",11,0)
  7486    .S X=$P(D GRP(.3),"^ ",1),DGNA= $S(X'="Y": 1,1:0)
  7487   "RTN","DGR P7",12,0)
  7488    .W !?9,"S C Award Da te: ",$$DA TENP^DG101 0P0(DGRPX, 12) W ?53, "Unemploya ble: " S X =5,Z1=0 D  YN2
  7489   "RTN","DGR P7",13,0)
  7490    .W !?19," P&T: " S X =4,Z1=23 D  YN2 I $P( DGRP(.3),U ,4)["Y" W  "P&T Effec tive Date:  " W:$P(DG RP(.3),U,1 3)']"" "UN ANSWERED"  I $P(DGRP( .3),U,13)] "" S Y=$P( DGRP(.3),U ,13) D DD^ %DT W $G(Y )
  7491   "RTN","DGR P7",14,0)
  7492    W !?9,"Ra ted Incomp .: " S X=$ $YN2^DG101 0P0(DGRP(. 29),12) W  X D:X["Y"
  7493   "RTN","DGR P7",15,0)
  7494    .W "   Da te (CIVIL) : ",$$DATE NP^DG1010P 0(DGRP(.29 ),2)
  7495   "RTN","DGR P7",16,0)
  7496    .W "    D ate (VA):  ",$$DATENP ^DG1010P0( DGRP(.29), 1)
  7497   "RTN","DGR P7",17,0)
  7498    S DGRPX=D GRP(.31) W  !?10,"Cla im Number:  ",$S($P(D GRPX,"^",3 )]"":$P(DG RPX,"^",3) ,1:DGRPU), !?11,"Fold er Loc.: " ,$$POINT^D G1010P0(DG RP(.31),4, 4)
  7499   "RTN","DGR P7",18,0)
  7500    S Z=2 D W W^DGRPV ;m onetary be nefits sec tion
  7501   "RTN","DGR P7",19,0)
  7502    W "   Aid  & Attenda nce: " S Z =$$YN2^DG1 010P0(DGRP (.362),12)  D MBCK S  Z1=31 D WW 1^DGRPV
  7503   "RTN","DGR P7",20,0)
  7504    W "Houseb ound: ",$$ YN2^DG1010 P0(DGRP(.3 62),13) D  MBCK
  7505   "RTN","DGR P7",21,0)
  7506    W !?12,"V A Pension:  " S Z=$$Y N2^DG1010P 0(DGRP(.36 2),14) D M BCK S Z1=2 5 D WW1^DG RPV
  7507   "RTN","DGR P7",22,0)
  7508    I $P(DGRP (.362),"^" ,14)]"" D   ;DG*5.3*8 42
  7509   "RTN","DGR P7",23,0)
  7510    .I DGRPV= 1 D DISPPE N^DGRP7CP  Q
  7511   "RTN","DGR P7",24,0)
  7512    .I ($P(DG RP(.362)," ^",14)="N" )&($P(DGRP (.385),"^" ,3)]"") W  "Pension A /T Date: " _$$DATENP^ DG1010P0(D GRP(.385), 3) Q
  7513   "RTN","DGR P7",25,0)
  7514    .I ($P(DG RP(.362)," ^",14)="Y" )&($P(DGRP (.385),"^" ,1)]"") W  "Pension A /T Date: " _$$DATENP^ DG1010P0(D GRP(.385), 1) Q
  7515   "RTN","DGR P7",26,0)
  7516    W !?9,"VA  Disabilit y: ",$$YN2 ^DG1010P0( DGRP(.3),1 1) D MBCK
  7517   "RTN","DGR P7",27,0)
  7518    W !?4,"To tal Check  Amount: "  S X=$$DISP ^DG1010P0( DGRP(.362) ,20,'DGMBC K) W $S(X: "$"_X,1:X)
  7519   "RTN","DGR P7",28,0)
  7520    W !?10,"G I Insuranc e: " S Z=$ $YN2^DG101 0P0(DGRP(. 362),17) S  Z1=35 D W W1^DGRPV
  7521   "RTN","DGR P7",29,0)
  7522    W "Amount : " S X=$$ DISP^DG101 0P0(DGRP(. 362),6) W  $S(X:"$"_X ,1:X)
  7523   "RTN","DGR P7",30,0)
  7524    S Z=3 D W W^DGRPV S  DGRPE=+DGR P(.36),Z=$ S($D(^DIC( 8,+DGRPE,0 )):$P(^(0) ,"^",1),1: DGRPU)
  7525   "RTN","DGR P7",31,0)
  7526    ;DG*5.3*9 52
  7527   "RTN","DGR P7",32,0)
  7528    ;if the p rimary eli gibility c ode is EXP ANDED MH C ARE
  7529   "RTN","DGR P7",33,0)
  7530    ;concaten ate expand ed mental  healthcare  type when  displayin g the prim ary eligib ility code
  7531   "RTN","DGR P7",34,0)
  7532    ;Vista Re gistration  screen 7
  7533   "RTN","DGR P7",35,0)
  7534    I $D(^DIC (8,+DGRPE, 0)),$P(^(0 ),"^",9)=2 3,$G(DGRP( .55))'=""  S Z=Z_" -  "_$E($$OTH SOC^DGOTHD 1($G(DGRP( .55))),1,2 4),(DGPRVS EL,DGOTHMS G)=0
  7535   "RTN","DGR P7",36,0)
  7536    W "  Prim ary Elig C ode: ",Z D  AAC1^DGLO CK2 I DGAA C(1)]"" W  !?8,"Agenc y/Country:  ",$S($D(^ DIC(35,+$P (DGRP(.3), "^",9),0)) :$P(^(0)," ^",1),1:DG RPU)
  7537   "RTN","DGR P7",37,0)
  7538    W !?4,"Ot her Elig C ode(s): "  S I1="" F  I=0:0 S I= $O(^DPT("A EL",DFN,I) ) Q:'I  I  $D(^DIC(8, +I,0)),I'= DGRPE S I1 =I1+1 W:I1 >1 !?24 W  $P(^(0),"^ ",1)
  7539   "RTN","DGR P7",38,0)
  7540    W:'I1 "NO  ADDITIONA L ELIGIBIL ITIES IDEN TIFIED"
  7541   "RTN","DGR P7",39,0)
  7542    S DGRPX=+ $P(DGRP(.3 2),"^",3)  W !?5,"Per iod of Ser vice: ",$S ($D(^DIC(2 1,+DGRPX,0 )):$P(^(0) ,"^",1),1: DGRPU)
  7543   "RTN","DGR P7",40,0)
  7544    D ^DGYZOD S G:'DGODS  CONT S DG RPX=$S($D( ^DPT(DFN," ODS")):^(" ODS"),1:"" ) W !?6,"R ecalled to  Duty: ",$ S($P(DGRPX ,"^",2)=1: "FROM NATI ONAL GUARD S",$P(DGRP X,"^",2)=2 :"FROM RES ERVES",$P( DGRPX,"^", 2)=0:"NO", 1:DGRPU)
  7545   "RTN","DGR P7",41,0)
  7546    W !?18,"R ank: ",$S( $D(^DIC(25 002.1,+$P( DGRPX,"^", 3),0)):$P( ^(0),"^",1 ),1:DGRPU)
  7547   "RTN","DGR P7",42,0)
  7548   CONT ;
  7549   "RTN","DGR P7",43,0)
  7550    ;display  Combat Vet  Eligibili ty, if pre sent
  7551   "RTN","DGR P7",44,0)
  7552    N DGCV,SH AD
  7553   "RTN","DGR P7",45,0)
  7554    S SHAD=$P (DGRP(.321 ),"^",15)   ;SHAD Ind icator
  7555   "RTN","DGR P7",46,0)
  7556    S DGCV=$$ CVEDT^DGCV (DFN) I +$ G(DGCV)=1  D
  7557   "RTN","DGR P7",47,0)
  7558    . W !,"<3 .1> Combat  Vet Elig. : "
  7559   "RTN","DGR P7",48,0)
  7560    . W $S($P (DGCV,U,3) =1:"ELIGIB LE",$P(DGC V,U,3)=0:" EXPIRED",1 :"")
  7561   "RTN","DGR P7",49,0)
  7562    . I $P($G (DGCV),U,2 )]"" D
  7563   "RTN","DGR P7",50,0)
  7564    . . S Y=$ P(DGCV,U,2 ) D DD^%DT
  7565   "RTN","DGR P7",51,0)
  7566    . . W " E nd Date: " _Y
  7567   "RTN","DGR P7",52,0)
  7568    . I SHAD= 1 W ?56,"< 3.2>Proj 1 12/SHAD: Y ES"  ;Only  display i f YES
  7569   "RTN","DGR P7",53,0)
  7570    ;
  7571   "RTN","DGR P7",54,0)
  7572    I (+$G(DG CV)'=1)&(S HAD=1) W ! ,?56,"<3.2 >Proj 112/ SHAD: YES"
  7573   "RTN","DGR P7",55,0)
  7574    ;
  7575   "RTN","DGR P7",56,0)
  7576    ;print sc  disabilit ies (per p atient)
  7577   "RTN","DGR P7",57,0)
  7578    W ! S Z=4  D WW^DGRP V W " Serv ice Connec ted Condit ions as st ated by ap plicant" S  X="",$P(X ,"-",52)=" " W !?4,X
  7579   "RTN","DGR P7",58,0)
  7580    W !?4 S I 3=0 F I=0: 0 S I=$O(^ DPT(DFN,.3 73,I)) Q:' I  S I1=$P (^(I,0),"^ ",1)_" ("_ +$P(^(0)," ^",2)_"%),  ",I3=I W: (79-$X)<$L (I1) !?4 W  I1
  7581   "RTN","DGR P7",59,0)
  7582    W:'I3 ?4, "NONE STAT ED"
  7583   "RTN","DGR P7",60,0)
  7584   Q K DGAAC, DGNA,DGODS ,DGRP,DGRP E,DGRPX,I, I1,I2,I3,X ,X1,Z,Z1
  7585   "RTN","DGR P7",61,0)
  7586    G ^DGRPP
  7587   "RTN","DGR P7",62,0)
  7588   YN S Z=$S( $P(DGRPX," ^",X)="Y": "YES",$P(D GRPX,"^",X )="N":"NO" ,$P(DGRPX, "^",X)="U" :"UNKNOWN" ,1:"UNANSW ERED") D W W1^DGRPV
  7589   "RTN","DGR P7",63,0)
  7590    Q
  7591   "RTN","DGR P7",64,0)
  7592   YN2 S Z=$S (DGNA:"N/A ",$P(DGRPX ,"^",X)="Y ":"YES",$P (DGRPX,"^" ,X)="N":"N O",$P(DGRP X,"^",X)=" U":"UNKNOW N",1:"UNAN SWERED") D  WW1^DGRPV
  7593   "RTN","DGR P7",65,0)
  7594    Q
  7595   "RTN","DGR P7",66,0)
  7596   MBCK ;flag  for any M B Y/N fiel ds = yes
  7597   "RTN","DGR P7",67,0)
  7598    S DGMBCK= $S($G(DGMB CK):1,(X=" Y"):1,1:0)
  7599   "RTN","DGR P7",68,0)
  7600    Q
  7601   "RTN","DGR PD")
  7602   0^17^B1061 42283
  7603   "RTN","DGR PD",1,0)
  7604   DGRPD ;ALB /MRL,MLR,J AN,LBD,EG, BRM,JRC,BA J,JAM-PATI ENT INQUIR Y (NEW) ;J uly 09, 20 14  12:16p m
  7605   "RTN","DGR PD",2,0)
  7606    ;;5.3;Reg istration; **109,124, 121,57,161 ,149,286,3 58,436,445 ,489,498,5 06,513,518 ,550,545,5 68,585,677 ,703,688,8 87,907,925 ,936,940,9 41,952**;A ug 13, 199 3;Build 68
  7607   "RTN","DGR PD",3,0)
  7608    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  7609   "RTN","DGR PD",4,0)
  7610    ;
  7611   "RTN","DGR PD",5,0)
  7612    ; *286* N ewing vari ables X,Y  in OKLINE  subroutine
  7613   "RTN","DGR PD",6,0)
  7614    ; *358* I f a patien t is on a  domiciliar y ward, do n't displa y MEANS
  7615   "RTN","DGR PD",7,0)
  7616    ; TEST re quired/Med ication Co payment Ex emption me ssages
  7617   "RTN","DGR PD",8,0)
  7618    ; *436* I f an inpat ient is no t on a dom iciliary w ard, don't  display
  7619   "RTN","DGR PD",9,0)
  7620    ; Medicat ion Copaym ent Exempt ion messag e
  7621   "RTN","DGR PD",10,0)
  7622    ; *545* A dd death i nformation  near the  remarks fi eld
  7623   "RTN","DGR PD",11,0)
  7624    ; *677* A dded Emerg ency Respo nse
  7625   "RTN","DGR PD",12,0)
  7626    ; *688* M odified to  display C ountry and  Foreign A ddress
  7627   "RTN","DGR PD",13,0)
  7628    ; *936* M odified to  display H ealth Bene fit Plans
  7629   "RTN","DGR PD",14,0)
  7630    ; *940* # 879316,#87 9318 - Dis play Perma nent & Tot al Disable d Status
  7631   "RTN","DGR PD",15,0)
  7632    ; *941* # 887088 - R edesign of  Inquiry S creen layo ut for dis playing th e addresse
  7633   "RTN","DGR PD",16,0)
  7634    ;
  7635   "RTN","DGR PD",17,0)
  7636    ; Integra tion Agree ments:
  7637   "RTN","DGR PD",18,0)
  7638    ; 6138 -  DGHBPUTL A PI
  7639   "RTN","DGR PD",19,0)
  7640    ;
  7641   "RTN","DGR PD",20,0)
  7642   SEL K DFN, DGRPOUT W  ! S DIC="^ DPT(",DIC( 0)="AEQMZ"  D ^DIC G  Q:Y'>0 S D FN=+Y N Y  W ! S DIR( 0)="E" D ^ DIR G SEL: $D(DTOUT)! ($D(DUOUT) ) D EN G S EL
  7643   "RTN","DGR PD",21,0)
  7644   EN ;call t o display  patient in quiry - in put DFN
  7645   "RTN","DGR PD",22,0)
  7646    ;MPI/PD C HANGE
  7647   "RTN","DGR PD",23,0)
  7648    S DGCMOR= "UNSPECIFI ED",DGMPI= $G(^DPT(+D FN,"MPI"))
  7649   "RTN","DGR PD",24,0)
  7650    K DGRPOUT ,DGHOW S D GABBRV=$S( $D(^DG(43, 1,0)):+$P( ^(0),"^",3 8),1:0),DG RPU="UNSPE CIFIED" D  DEM^VADPT, HDR^DGRPD1
  7651   "RTN","DGR PD",25,0)
  7652    ;JAM begi n changes  Patch DG*5 .3*941 add  .115 and  new addres s fields l ayout
  7653   "RTN","DGR PD",26,0)
  7654    ;DG*5.3*9 52 add .55  into DRPG  array
  7655   "RTN","DGR PD",27,0)
  7656    F I=0,.11 ,.13,.121, .122,.31,. 32,.36,.36 1,.141,.3, .115,.55 S  DGRP(I)=$ S($D(^DPT( DFN,I)):^( I),1:"")
  7657   "RTN","DGR PD",28,0)
  7658    ;jam DG*5 .3*925 RM# 788099 cha nge labels  to "Perma nent Maili ng Address " and "Tem porary Mai ling Addre ss"
  7659   "RTN","DGR PD",29,0)
  7660    ;
  7661   "RTN","DGR PD",30,0)
  7662    W " Resid ential Add ress: "
  7663   "RTN","DGR PD",31,0)
  7664    W ?40,"Pe rmanent Ma iling Addr ess: "
  7665   "RTN","DGR PD",32,0)
  7666    S DGAD=.1 15,(DGA1,D GA2)=1 D A L^DGRPU(35 ) S DGAD=. 11,DGA1=1, DGA2=2 D A L^DGRPU(35 )
  7667   "RTN","DGR PD",33,0)
  7668    W !?5
  7669   "RTN","DGR PD",34,0)
  7670    N Z,Z1
  7671   "RTN","DGR PD",35,0)
  7672    S Z1=39,Z =$S($D(DGA (1)):DGA(1 ),1:"NONE  ON FILE")  D WW1^DGRP V W $S($D( DGA(2)):DG A(2),1:"NO  PERMANENT  MAILING A DDRESS")
  7673   "RTN","DGR PD",36,0)
  7674    ; loop th rough DGA  array begi nning with  DGA(2) an d print da ta at ?5 ( odds) and  ?44 (evens )
  7675   "RTN","DGR PD",37,0)
  7676    S I=2 F I 1=0:0 S I= $O(DGA(I))  Q:I=""  W :(I#2)!($X >40) !?5 W :'(I#2) ?4 4 W DGA(I)
  7677   "RTN","DGR PD",38,0)
  7678    N DGCC
  7679   "RTN","DGR PD",39,0)
  7680    S DGCC=$$ COUNTY^DGR PCADD(.DGR P,.115) ;  print Coun ty if appl icable
  7681   "RTN","DGR PD",40,0)
  7682    W !?5,"Co unty: "_DG CC
  7683   "RTN","DGR PD",41,0)
  7684    S DGCC=$$ COUNTY^DGR PCADD(.DGR P,.11) ; p rint Count y if appli cable
  7685   "RTN","DGR PD",42,0)
  7686    W ?44,"Co unty: "_DG CC
  7687   "RTN","DGR PD",43,0)
  7688    W !?6,"Ph one: ",$S( $P(DGRP(.1 3),U,1)]"" :$P(DGRP(. 13),U,1),1 :DGRPU)
  7689   "RTN","DGR PD",44,0)
  7690    W ?42,"Ba d Addr: ", $$EXTERNAL ^DILFD(2,. 121,"",$P( DGRP(.11), U,16))
  7691   "RTN","DGR PD",45,0)
  7692    W !?5,"Of fice: ",$S ($P(DGRP(. 13),U,2)]" ":$P(DGRP( .13),U,2), 1:DGRPU)
  7693   "RTN","DGR PD",46,0)
  7694    W ?46,"Ce ll: ",$S($ P(DGRP(.13 ),U,4)]"": $P(DGRP(.1 3),U,4),1: DGRPU)
  7695   "RTN","DGR PD",47,0)
  7696    W !?44,"E -mail: ",$ S($P(DGRP( .13),U,3)] "":$P(DGRP (.13),U,3) ,1:DGRPU)
  7697   "RTN","DGR PD",48,0)
  7698    W !!
  7699   "RTN","DGR PD",49,0)
  7700    K DGA,DGA 1,DGA2
  7701   "RTN","DGR PD",50,0)
  7702    I $P(DGRP (.121),"^" ,9)="Y" S  DGAD=.121, (DGA1,DGA2 )=1 D AL^D GRPU(30)
  7703   "RTN","DGR PD",51,0)
  7704    N CONACT
  7705   "RTN","DGR PD",52,0)
  7706    ; set Con fidential  Active Fla g
  7707   "RTN","DGR PD",53,0)
  7708    S CONACT= $P(DGRP(.1 41),"^",9)
  7709   "RTN","DGR PD",54,0)
  7710    I CONACT= "Y" D
  7711   "RTN","DGR PD",55,0)
  7712    .; check  the begin/ end dates,  set activ e flag to  NO and do  not displa y if outsi de the dat e range 
  7713   "RTN","DGR PD",56,0)
  7714    .N DGCABE G,DGCAEND, DGI
  7715   "RTN","DGR PD",57,0)
  7716    .S DGCABE G=$P(DGRP( .141),U,7) ,DGCAEND=$ P(DGRP(.14 1),U,8)
  7717   "RTN","DGR PD",58,0)
  7718    .I 'DGCAB EG!(DGCABE G>DT)!(DGC AEND&(DGCA END<DT)) S  CONACT="N " Q
  7719   "RTN","DGR PD",59,0)
  7720    .S DGAD=. 141,DGA1=1 ,DGA2=2 D  AL^DGRPU(3 0)
  7721   "RTN","DGR PD",60,0)
  7722    W " Tempo rary Maili ng Address : "
  7723   "RTN","DGR PD",61,0)
  7724    W ?40,"Co nfidential  Mailing A ddress: "
  7725   "RTN","DGR PD",62,0)
  7726    W !?5
  7727   "RTN","DGR PD",63,0)
  7728    W $S($D(D GA(1)):DGA (1),1:"NO  TEMPORARY  MAILING AD DRESS") W  ?44,$S($D( DGA(2)):DG A(2),1:"NO NE ON FILE ")
  7729   "RTN","DGR PD",64,0)
  7730    ; loop th rough DGA  array begi nning with  DGA(2) an d print da ta at ?5 ( odds) and  ?44 (evens )
  7731   "RTN","DGR PD",65,0)
  7732    S I=2 F I 1=0:0 S I= $O(DGA(I))  Q:I=""  W :(I#2)!($X >40) !?5 W :'(I#2) ?4 4 W DGA(I)
  7733   "RTN","DGR PD",66,0)
  7734    W !
  7735   "RTN","DGR PD",67,0)
  7736    I $D(DGA( 1)) D
  7737   "RTN","DGR PD",68,0)
  7738    .S DGCC=$ $COUNTY^DG RPCADD(.DG RP,.121) ;  print Cou nty if app licable 
  7739   "RTN","DGR PD",69,0)
  7740    .W ?5,"Co unty: "_DG CC
  7741   "RTN","DGR PD",70,0)
  7742    I $D(DGA( 2)) D
  7743   "RTN","DGR PD",71,0)
  7744    .S DGCC=$ $COUNTY^DG RPCADD(.DG RP,.141) ;  print Cou nty if app licable
  7745   "RTN","DGR PD",72,0)
  7746    .W ?44,"C ounty: "_D GCC
  7747   "RTN","DGR PD",73,0)
  7748    ;W !?2,"C ASS Cert:  "_$S($P(DG RP(.121),U ,15)="Y":" Certified" ,$P(DGRP(. 121),U,15) ="F":"Fail ed",1:"NC" )
  7749   "RTN","DGR PD",74,0)
  7750    ;W ?41,"C ASS Cert:  "_$S($P(DG RP(.141),U ,17)="Y":" Certified" ,$P(DGRP(. 141),U,17) ="F":"Fail ed",1:"NC" )
  7751   "RTN","DGR PD",75,0)
  7752    W !?6,"Ph one: ",$S( $P(DGRP(.1 21),U,9)'= "Y":"NOT A PPLICABLE" ,$P(DGRP(. 121),U,10) ]"":$P(DGR P(.121),U, 10),1:DGRP U)
  7753   "RTN","DGR PD",76,0)
  7754    W ?45,"Ph one: ",$S( $P(DGRP(.1 41),U,9)'= "Y":"NOT A PPLICABLE" ,CONACT'=" Y":"NOT AP PLICABLE", $P(DGRP(.1 3),U,15)]" ":$P(DGRP( .13),U,15) ,1:DGRPU)
  7755   "RTN","DGR PD",77,0)
  7756    S X="NOT  APPLICABLE "
  7757   "RTN","DGR PD",78,0)
  7758    I $P(DGRP (.121),U,9 )="Y" D
  7759   "RTN","DGR PD",79,0)
  7760    .S Y=$P(D GRP(.121), U,7) X:Y]" " ^DD("DD" )
  7761   "RTN","DGR PD",80,0)
  7762    .S X=$S(Y ]"":Y,1:DG RPU)_"-",Y =$P(DGRP(. 121),U,8)  X:Y]"" ^DD ("DD")
  7763   "RTN","DGR PD",81,0)
  7764    .S X=X_$S (Y]"":Y,1: DGRPU)
  7765   "RTN","DGR PD",82,0)
  7766    N DGACT,D GTYP,DGCAN ,DGBEG,DGE ND,DGZ,DGX X,DGX,DGTY PNAM,DGCAT
  7767   "RTN","DGR PD",83,0)
  7768    W !?2,"Fr om/To: ",X
  7769   "RTN","DGR PD",84,0)
  7770    S DGX="NO T APPLICAB LE"
  7771   "RTN","DGR PD",85,0)
  7772    I CONACT= "Y" D
  7773   "RTN","DGR PD",86,0)
  7774    .S (DGZ,D GX)="" F D GI=7,8 S D GZ=$P(DGRP (.141),"^" ,DGI),Y=DG Z D
  7775   "RTN","DGR PD",87,0)
  7776    ..I DGI=7  X:Y]"" ^D D("DD") S  DGBEG=Y,DG X=Y
  7777   "RTN","DGR PD",88,0)
  7778    ..I DGI=8  X:Y]"" ^D D("DD") S  DGEND=Y,DG X=DGX_"-"_ $S(Y]"":Y, 1:"UNANSWE RED")
  7779   "RTN","DGR PD",89,0)
  7780    W ?43,"Fr om/To: "_D GX
  7781   "RTN","DGR PD",90,0)
  7782    W !?41,"C onfidentia l Address  Categories : " I $D(^ DPT(DFN,.1 4)) D
  7783   "RTN","DGR PD",91,0)
  7784    .; If not  active, d o not disp lay catego ries
  7785   "RTN","DGR PD",92,0)
  7786    .I CONACT '="Y" Q
  7787   "RTN","DGR PD",93,0)
  7788    .S DGCAT= $$GET1^DID (2.141,.01 ,"","POINT ER","","DG ERR")
  7789   "RTN","DGR PD",94,0)
  7790    .S DGX="" ,DGCAN=""  F  S DGCAN =$O(^DPT(D FN,.14,DGC AN)) Q:DGC AN=""  D
  7791   "RTN","DGR PD",95,0)
  7792    ..Q:'$D(^ DPT(DFN,.1 4,DGCAN,0) )
  7793   "RTN","DGR PD",96,0)
  7794    ..S DGTYP =$P(^DPT(D FN,.14,DGC AN,0),"^", 1),DGACT=$ P(^DPT(DFN ,.14,DGCAN ,0),"^",2)
  7795   "RTN","DGR PD",97,0)
  7796    ..S DGACT =$S(DGACT= "Y":"Activ e",DGACT=" N":"Inacti ve",1:"Una nswered")
  7797   "RTN","DGR PD",98,0)
  7798    ..S DGTYP NAM="" F D GI=1:1 S D GTYPNAM=$P (DGCAT,";" ,DGI) Q:DG TYPNAM=""   D
  7799   "RTN","DGR PD",99,0)
  7800    ...I DGTY PNAM[DGTYP  S DGTYPNA M=$P(DGTYP NAM,":",2) ,DGX=DGTYP NAM_"("_DG ACT_")"_", "_DGX
  7801   "RTN","DGR PD",100,0)
  7802    S DGXX=""  F DGI=1:1  S DGXX=$P (DGX,",",D GI) Q:DGXX =""  D
  7803   "RTN","DGR PD",101,0)
  7804    .W !?42,D GXX
  7805   "RTN","DGR PD",102,0)
  7806    ;
  7807   "RTN","DGR PD",103,0)
  7808    I '$$OKLI NE^DGRPD1( 16) G Q
  7809   "RTN","DGR PD",104,0)
  7810    N DGEMER  S DGEMER=$ $EXTERNAL^ DILFD(2,.1 81,"",$P($ G(^DPT(DFN ,.18)),"^" ))
  7811   "RTN","DGR PD",105,0)
  7812    W:DGEMER] "" !?32,"E mergency R esponse: " ,DGEMER
  7813   "RTN","DGR PD",106,0)
  7814    I 'DGABBR V W !!?4," POS: ",$S( $D(^DIC(21 ,+$P(DGRP( .32),"^",3 ),0)):$P(^ (0),"^",1) ,1:DGRPU), ?42,"Claim  #: ",$S($ P(DGRP(.31 ),"^",3)]" ":$P(DGRP( .31),"^",3 ),1:"UNSPE CIFIED")
  7815   "RTN","DGR PD",107,0)
  7816    I 'DGABBR V W !?2,"R elig: ",$S ($D(^DIC(1 3,+$P(DGRP (0),"^",8) ,0)):$P(^( 0),"^",1), 1:DGRPU),? 46,"Birth  Sex: ",$S( $P(VADM(5) ,"^",2)]"" :$P(VADM(5 ),"^",2),1 :"UNSPECIF IED") ; DG *5.3*907
  7817   "RTN","DGR PD",108,0)
  7818    I 'DGABBR V W ! D
  7819   "RTN","DGR PD",109,0)
  7820    .N RACE,E THNIC,PTR, VAL,X,DIWL ,DIWR,DIWF
  7821   "RTN","DGR PD",110,0)
  7822    .K ^UTILI TY($J,"W")
  7823   "RTN","DGR PD",111,0)
  7824    .S PTR=0  F  S PTR=+ $O(^DPT(DF N,.02,PTR) ) Q:'PTR   D
  7825   "RTN","DGR PD",112,0)
  7826    ..S VAL=+ $G(^DPT(DF N,.02,PTR, 0))
  7827   "RTN","DGR PD",113,0)
  7828    ..Q:$$INA CTIVE^DGUT L4(VAL,1)
  7829   "RTN","DGR PD",114,0)
  7830    ..S VAL=$ $PTR2TEXT^ DGUTL4(VAL ,1) S:+$O( ^DPT(DFN,. 02,PTR)) V AL=VAL_",  "
  7831   "RTN","DGR PD",115,0)
  7832    ..S X=VAL ,DIWL=0,DI WR=30,DIWF ="" D ^DIW P
  7833   "RTN","DGR PD",116,0)
  7834    .M RACE=^ UTILITY($J ,"W",0) S: $G(RACE(1, 0))="" RAC E(1,0)="UN ANSWERED"
  7835   "RTN","DGR PD",117,0)
  7836    .K ^UTILI TY($J,"W")
  7837   "RTN","DGR PD",118,0)
  7838    .S PTR=0  F  S PTR=+ $O(^DPT(DF N,.06,PTR) ) Q:'PTR   D
  7839   "RTN","DGR PD",119,0)
  7840    ..S VAL=+ $G(^DPT(DF N,.06,PTR, 0))
  7841   "RTN","DGR PD",120,0)
  7842    ..Q:$$INA CTIVE^DGUT L4(VAL,2)
  7843   "RTN","DGR PD",121,0)
  7844    ..S VAL=$ $PTR2TEXT^ DGUTL4(VAL ,2) S:+$O( ^DPT(DFN,. 06,PTR)) V AL=VAL_",  "
  7845   "RTN","DGR PD",122,0)
  7846    ..S X=VAL ,DIWL=0,DI WR=30,DIWF ="" D ^DIW P
  7847   "RTN","DGR PD",123,0)
  7848    .M ETHNIC =^UTILITY( $J,"W",0)  S:$G(ETHNI C(1,0))=""  ETHNIC(1, 0)="UNANSW ERED"
  7849   "RTN","DGR PD",124,0)
  7850    .K ^UTILI TY($J,"W")
  7851   "RTN","DGR PD",125,0)
  7852    .W ?3,"Ra ce: ",RACE (1,0),?40, "Ethnicity : ",ETHNIC (1,0)
  7853   "RTN","DGR PD",126,0)
  7854    .F X=2:1  Q:'$D(RACE (X,0))&'$D (ETHNIC(X, 0))  W !,? 9,$G(RACE( X,0)),?51, $G(ETHNIC( X,0))
  7855   "RTN","DGR PD",127,0)
  7856    I '$$OKLI NE^DGRPD1( 16) G Q
  7857   "RTN","DGR PD",128,0)
  7858    D LANGUAG E
  7859   "RTN","DGR PD",129,0)
  7860    I '$$OKLI NE^DGRPD1( 10) G Q
  7861   "RTN","DGR PD",130,0)
  7862    ;display  cv status  #4156
  7863   "RTN","DGR PD",131,0)
  7864    N DGCV S  DGCV=$$CVE DT^DGCV(+D FN)
  7865   "RTN","DGR PD",132,0)
  7866    W !!,?2," Combat Vet  Status: " _$S($P(DGC V,U,3)=1:" ELIGIBLE", $P(DGCV,U, 3)="":"NOT  ELIGIBLE" ,1:"EXPIRE D") I DGCV >0 W ?45," End Date:  "_$$FMTE^X LFDT($P(DG CV,U,2),"5 DZ")
  7867   "RTN","DGR PD",133,0)
  7868    ;display  primary el igibility
  7869   "RTN","DGR PD",134,0)
  7870    S X1=DGRP (.36),X=$P (DGRP(.361 ),"^",1) W  !,"Primar y Eligibil ity: ",$S( $D(^DIC(8, +X1,0)):$P (^(0),"^", 1)_" ("_$S (X="V":"VE RIFIED",X= "P":"PENDI NG VERIFIC ATION",X=" R":"PENDIN G REVERIFI CATION",1: "NOT VERIF IED")_")", 1:DGRPU)
  7871   "RTN","DGR PD",135,0)
  7872    ;*952 to  display th e Expanded  MH Care T ype
  7873   "RTN","DGR PD",136,0)
  7874    I $D(^DIC (8,+X1,0)) ,$P(^(0)," ^",9)=23,$ G(DGRP(.55 ))'="" W ! ,"Expanded  MH Care T ype: ",$$O THSOC^DGOT HD1($G(DGR P(.55)))
  7875   "RTN","DGR PD",137,0)
  7876    W !,"Othe r Eligibil ities: " F  I=0:0 S I =$O(^DIC(8 ,I)) Q:'I   I $D(^DIC (8,I,0)),I '=+X1 S X= $P(^(0),"^ ",1)_", "  I $D(^DPT( "AEL",DFN, I)) W:$X+$ L(X)>79 !? 21 W X
  7877   "RTN","DGR PD",138,0)
  7878    I '$$OKLI NE^DGRPD1( 16) G Q
  7879   "RTN","DGR PD",139,0)
  7880    ;employab ility stat us
  7881   "RTN","DGR PD",140,0)
  7882    W !?6,"Un employable : ",$S($P( DGRP(.3),U ,5)="Y":"Y ES",1:"NO" )
  7883   "RTN","DGR PD",141,0)
  7884    I '$$OKLI NE^DGRPD1( 19) G Q
  7885   "RTN","DGR PD",142,0)
  7886    ; KUM DG* 5.3*940 RM  #879316,# 879318 - D isplay Per manent & T otal Disab led status
  7887   "RTN","DGR PD",143,0)
  7888    W !?6,"Pe rmanent &  Total Disa bled: ",$S ($P(DGRP(. 3),U,4)="Y ":"YES",1: "NO")
  7889   "RTN","DGR PD",144,0)
  7890    I '$$OKLI NE^DGRPD1( 19) G Q
  7891   "RTN","DGR PD",145,0)
  7892    ;display  the catast rophic dis ability re view date  if there i s one
  7893   "RTN","DGR PD",146,0)
  7894    D CATDIS^ DGRPD1
  7895   "RTN","DGR PD",147,0)
  7896    I $G(DGPR FLG)=1 G Q :'$$OKLINE ^DGRPD1(19 ) D
  7897   "RTN","DGR PD",148,0)
  7898    . N DGPDT ,DGPTM
  7899   "RTN","DGR PD",149,0)
  7900    . W !,$$R EPEAT^XLFS TR("-",78)
  7901   "RTN","DGR PD",150,0)
  7902    . S DGPDT ="",DGPDT= $O(^DGS(41 .41,"ADC", DFN,DGPDT) ,-1)
  7903   "RTN","DGR PD",151,0)
  7904    . W !,"[P RE-REGISTE R DATE:] " _$S(DGPDT] "":$$FMTE^ XLFDT(DGPD T,"1D"),1: "NONE ON F ILE")
  7905   "RTN","DGR PD",152,0)
  7906    . S DGPTM =$$PCTEAM^ DGSDUTL(DF N)
  7907   "RTN","DGR PD",153,0)
  7908    . I $P(DG PTM,U,2)]" " W !,"[PR IMARY CARE  TEAM:] "_ $P(DGPTM,U ,2)
  7909   "RTN","DGR PD",154,0)
  7910    . W !,$$R EPEAT^XLFS TR("-",78)
  7911   "RTN","DGR PD",155,0)
  7912    ; Check i f patient  is an inpa tient and  on a DOM w ard
  7913   "RTN","DGR PD",156,0)
  7914    ; If inpa tient is o n a DOM wa rd, don't  display MT  or CP mes sages
  7915   "RTN","DGR PD",157,0)
  7916    ; If inpa tient is N OT on a DO M ward, do n't displa y CP messa ge
  7917   "RTN","DGR PD",158,0)
  7918    N DGDOM,D GDOM1,VAHO W,VAROOT,V AINDT,VAIP ,VAERR
  7919   "RTN","DGR PD",159,0)
  7920    G Q:'$$OK LINE^DGRPD 1(16)
  7921   "RTN","DGR PD",160,0)
  7922    D DOM^DGM TR
  7923   "RTN","DGR PD",161,0)
  7924    I '$G(DGD OM) D
  7925   "RTN","DGR PD",162,0)
  7926    .D DIS^DG MTU(DFN)
  7927   "RTN","DGR PD",163,0)
  7928    .D IN5^VA DPT
  7929   "RTN","DGR PD",164,0)
  7930    .I $G(VAI P(1))="" D  DISP^IBAR XEU(DFN,DT ,3,1)
  7931   "RTN","DGR PD",165,0)
  7932    ;I 'DGABB RV,$E(IOST ,1,2)="C-"  F I=$Y:1: 20 W !
  7933   "RTN","DGR PD",166,0)
  7934    D DIS^EAS ECU(DFN) ; Added for  LTC III (D G*5.3*518)
  7935   "RTN","DGR PD",167,0)
  7936    S VAIP("L ")=""
  7937   "RTN","DGR PD",168,0)
  7938    I $$OKLIN E^DGRPD1(1 4) D INP
  7939   "RTN","DGR PD",169,0)
  7940    I '$G(DGR POUT),($$O KLINE^DGRP D1(10)) D  SA ;*KNR*
  7941   "RTN","DGR PD",170,0)
  7942    ;MPI/PD C HANGE
  7943   "RTN","DGR PD",171,0)
  7944   Q D KVA^VA DPT K %DT, D0,D1,DGA, DGA1,DGA2, DGABBRV,DG AD,DGCC,DG CMOR,DGDOM ,DGLOCATN, DGMPI,DGRP ,DGRPU,DGS ,DGST,DGXF R0,DIC,DIR ,DTOUT,DUO UT,DIRUT,D IROUT,I,I1 ,L,LDM,POP ,SDCT,VA,X ,X1,Y Q
  7945   "RTN","DGR PD",172,0)
  7946    ;
  7947   "RTN","DGR PD",173,0)
  7948   INP S VAIP ("D")="L"  D INP^DGPM V10
  7949   "RTN","DGR PD",174,0)
  7950    S DGPMT=0
  7951   "RTN","DGR PD",175,0)
  7952    D CS^DGPM V10 K DGPM T,DGPMIFN  K:'$D(DGSW ITCH) DGPM VI,DGPMDCD  Q
  7953   "RTN","DGR PD",176,0)
  7954   SA F I=0:0  S I=$O(^D GS(41.1,"B ",DFN,I))  G CL:'I S  X=^DGS(41. 1,I,0) I $ P(X,"^",2) >(DT-1),$P (X,"^",13) ']"",'$P(X ,"^",17) S  L=$P(X,"^ ",2) D:$$O KLINE^DGRP D1(17) SAA  Q:$G(DGRP OUT)
  7955   "RTN","DGR PD",177,0)
  7956    Q
  7957   "RTN","DGR PD",178,0)
  7958   SAA ;Sched uled Admit  Data
  7959   "RTN","DGR PD",179,0)
  7960    W !!?14," Scheduled  Admit"
  7961   "RTN","DGR PD",180,0)
  7962    W:$D(^DIC (42,+$P(X, U,8),0)) "  on ward " _$P(^(0),U )
  7963   "RTN","DGR PD",181,0)
  7964    W:$D(^DIC (45.7,+$P( X,U,9),0))  " for tre ating spec ialty "_$P (^(0),U)
  7965   "RTN","DGR PD",182,0)
  7966    W " on "_ $$FMTE^XLF DT(L,"5DZ" )
  7967   "RTN","DGR PD",183,0)
  7968    Q  ;SAA
  7969   "RTN","DGR PD",184,0)
  7970    ;
  7971   "RTN","DGR PD",185,0)
  7972   CL G FA:$O (^DPT(DFN, "DE",0))=" " S SDCT=0  F I=0:0 S  I=$O(^DPT (DFN,"DE", I)) Q:'I   I $D(^(I,0 )),$P(^(0) ,"^",2)'=" I",$O(^(0) ) S SDCT=S DCT+1 W:SD CT=1 !!,"C urrently e nrolled in  " W:$X>50  !?22 W $S ($D(^SC(+^ (0),0)):$P (^(0),"^", 1)_", ",1: "")
  7973   "RTN","DGR PD",186,0)
  7974    ;
  7975   "RTN","DGR PD",187,0)
  7976   FA ;
  7977   "RTN","DGR PD",188,0)
  7978    N DGARRAY ,SDCNT
  7979   "RTN","DGR PD",189,0)
  7980    S DGARRAY ("FLDS")=" 1;2;3;18", DGARRAY(4) =DFN,DGARR AY(1)=DT,D GARRAY("SO RT")="P"
  7981   "RTN","DGR PD",190,0)
  7982    S SDCNT=$ $SDAPI^SDA MA301(.DGA RRAY),CT=0  W !!,"Fut ure Appoin tments: "
  7983   "RTN","DGR PD",191,0)
  7984    ;if there  is lower  subscripts  hanging f rom the 10 1 node,
  7985   "RTN","DGR PD",192,0)
  7986    ;then it  is a valid  appointme nt, otherw ise it is
  7987   "RTN","DGR PD",193,0)
  7988    ;an error  eg 01/20/ 2005
  7989   "RTN","DGR PD",194,0)
  7990    ;G:'$$OKL INE^DGRPD1 (13) RMK ; *///*
  7991   "RTN","DGR PD",195,0)
  7992    I $D(^TMP ($J,"SDAMA 301",101)) =1 W "Appo intment Da tabase is  Unavailabl e" G RMK
  7993   "RTN","DGR PD",196,0)
  7994    I $O(^TMP ($J,"SDAMA 301",DFN,D T))'>0 W " NONE" G RM K
  7995   "RTN","DGR PD",197,0)
  7996    ;
  7997   "RTN","DGR PD",198,0)
  7998    W ?22,"Da te",?33,"T ime",?39," Clinic",!? 22 F I=22: 1:75 W "="
  7999   "RTN","DGR PD",199,0)
  8000    F FA=DT:0  S FA=$O(^ TMP($J,"SD AMA301",DF N,FA)) G R MK:'FA D   Q:CT>5
  8001   "RTN","DGR PD",200,0)
  8002    .N STAT S  STAT=$P($ P(^TMP($J, "SDAMA301" ,DFN,FA),U ,3),";")
  8003   "RTN","DGR PD",201,0)
  8004    .S C=+$P( ^TMP($J,"S DAMA301",D FN,FA),U,2 ) I STAT'[ "C" D
  8005   "RTN","DGR PD",202,0)
  8006    ..D COV
  8007   "RTN","DGR PD",203,0)
  8008    ..N DGAPP T S DGAPPT =$$FMTE^XL FDT($E(FA, 1,12),"5Z" )
  8009   "RTN","DGR PD",204,0)
  8010    ..W !?22, $P(DGAPPT, "@"),?33,$ P(DGAPPT," @",2)
  8011   "RTN","DGR PD",205,0)
  8012    ..W ?39,$ P($P(^TMP( $J,"SDAMA3 01",DFN,FA ),U,2),";" ,2)," ",CO V
  8013   "RTN","DGR PD",206,0)
  8014    ..Q
  8015   "RTN","DGR PD",207,0)
  8016    I $O(^TMP ($J,"SDAMA 301",DFN,F A))>0 W !, "See Sched uling opti ons for ad ditional a ppointment s."
  8017   "RTN","DGR PD",208,0)
  8018   RMK I '$G( DGRPOUT),( $$OKLINE^D GRPD1(15))  W !!,"Rem arks: ",$P (^DPT(DFN, 0),"^",10)  ;*///*
  8019   "RTN","DGR PD",209,0)
  8020    D GETS^DI Q(2,DFN_", ",".351;.3 53;.354;.3 55","E","P DTHINFO")
  8021   "RTN","DGR PD",210,0)
  8022    W !!
  8023   "RTN","DGR PD",211,0)
  8024    W "Date o f Death In formation"
  8025   "RTN","DGR PD",212,0)
  8026    W !,?5,"D ate of Dea th: ",$G(P DTHINFO(2, DFN_",",.3 51,"E"))
  8027   "RTN","DGR PD",213,0)
  8028    W !,?5,"S ource of N otificatio n: ",$G(PD THINFO(2,D FN_",",.35 3,"E"))
  8029   "RTN","DGR PD",214,0)
  8030    W !,?5,"U pdated Dat e/Time: ", $G(PDTHINF O(2,DFN_", ",.354,"E" ))
  8031   "RTN","DGR PD",215,0)
  8032    W !,?5,"L ast Edited  By: ",$G( PDTHINFO(2 ,DFN_",",. 355,"E")), !
  8033   "RTN","DGR PD",216,0)
  8034    I $$OKLIN E^DGRPD1(1 4) D EC^DG RPD1
  8035   "RTN","DGR PD",217,0)
  8036    ; KUM DG* 5.3*936 Ca ll tag to  display He alth Benef it Plans a ssigned to  Veteran
  8037   "RTN","DGR PD",218,0)
  8038    D HBP
  8039   "RTN","DGR PD",219,0)
  8040    K DGARRAY ,SDCNT,^TM P($J,"SDAM A301"),ADM ,L,TRN,DIS ,SSN,FA,C, COV,NOW,CT ,DGD,DGD1, I ;Y kille d after dg hinqky
  8041   "RTN","DGR PD",220,0)
  8042    Q
  8043   "RTN","DGR PD",221,0)
  8044    ; KUM DG* 5.3*936 Di splay Heal th Benefit  Plans ass igned to V eteran
  8045   "RTN","DGR PD",222,0)
  8046   HBP W !!," Health Ben efit Plans  Currently  Assigned  to Veteran :"
  8047   "RTN","DGR PD",223,0)
  8048    N DGHBP,H BP,DGCOUNT
  8049   "RTN","DGR PD",224,0)
  8050    S DGCOUNT =0
  8051   "RTN","DGR PD",225,0)
  8052    D GETHBP^ DGHBPUTL(D FN)
  8053   "RTN","DGR PD",226,0)
  8054    S DGHBP=" " F  S DGH BP=$O(HBP( "CUR",DGHB P)) Q:DGHB P=""  D
  8055   "RTN","DGR PD",227,0)
  8056    .W !,?3,D GHBP
  8057   "RTN","DGR PD",228,0)
  8058    .S DGCOUN T=DGCOUNT+ 1
  8059   "RTN","DGR PD",229,0)
  8060    I DGCOUNT =0 W !,?3, "None"
  8061   "RTN","DGR PD",230,0)
  8062    Q
  8063   "RTN","DGR PD",231,0)
  8064    ;
  8065   "RTN","DGR PD",232,0)
  8066   COV S COV= $S(+$P(^TM P($J,"SDAM A301",DFN, FA),U,18)= 7:" (Colla teral) ",1 :"")
  8067   "RTN","DGR PD",233,0)
  8068    S COV=COV _$S(STAT[" NT":" * NO  ACTION TA KEN *",STA T["N":" *  NO-SHOW *" ,1:""),CT= CT+1 Q
  8069   "RTN","DGR PD",234,0)
  8070    Q
  8071   "RTN","DGR PD",235,0)
  8072    ;
  8073   "RTN","DGR PD",236,0)
  8074   OREN S XQO RQUIT=1 Q: '$D(ORVP)   S DFN=+OR VP D EN R  !!,"Press  RETURN to  CONTINUE:  ",X:DTIME
  8075   "RTN","DGR PD",237,0)
  8076    Q
  8077   "RTN","DGR PD",238,0)
  8078   LANGUAGE ;  Get langu age data * ///*
  8079   "RTN","DGR PD",239,0)
  8080    S DGLANGD T=9999999, (DGPRFLAN, DGLANG0)=" "
  8081   "RTN","DGR PD",240,0)
  8082    S DGLANGD T=$O(^DPT( DFN,.207," B",DGLANGD T),-1)
  8083   "RTN","DGR PD",241,0)
  8084    I DGLANGD T="" G L1
  8085   "RTN","DGR PD",242,0)
  8086    S DGLANGD A=$O(^DPT( DFN,.207," B",DGLANGD T,0))
  8087   "RTN","DGR PD",243,0)
  8088    S DGLANG0 =$G(^DPT(D FN,.207,DG LANGDA,0)) ,Y=$P(DGLA NG0,U),DGP RFLAN=$P(D GLANG0,U,2 )
  8089   "RTN","DGR PD",244,0)
  8090    S Y=DGLAN GDT X ^DD( "DD") S DG LANGDT=Y
  8091   "RTN","DGR PD",245,0)
  8092   L1 W !!,"L anguage Da te/Time: " ,$S(DGLANG DT="":"UNA NSWERED",1 :DGLANGDT) ,!
  8093   "RTN","DGR PD",246,0)
  8094    W ?1,"Pre ferred Lan guage: ",$ S(DGPRFLAN ="":"UNANS WERED",1:D GPRFLAN)
  8095   "RTN","DGR PD",247,0)
  8096    K DGLANGD T,DGPRFLAN ,DGLANG0,D GLANGDA
  8097   "RTN","DGR PD",248,0)
  8098    Q
  8099   "RTN","DGR PDB")
  8100   0^18^B2432 1515
  8101   "RTN","DGR PDB",1,0)
  8102   DGRPDB ;AL B/AAS,JAN, ERC,PHH -  VIEW ONLY  SCREEN TO  DETERMINE  BILLING EL IGIBILITY  ;3/23/06 8 :16am
  8103   "RTN","DGR PDB",2,0)
  8104    ;;5.3;Reg istration; **26,50,35 8,570,631, 709,713,74 9,952**;Au g 13, 1993 ;Build 68
  8105   "RTN","DGR PDB",3,0)
  8106    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  8107   "RTN","DGR PDB",4,0)
  8108    ;
  8109   "RTN","DGR PDB",5,0)
  8110   % S:'$D(DG QUIT) DGQU IT=0
  8111   "RTN","DGR PDB",6,0)
  8112    G:DGQUIT  END S DIC= "^DPT(",DI C(0)="AEQM N" D ^DIC  G:+Y<1 END  S DFN=+Y  D EN
  8113   "RTN","DGR PDB",7,0)
  8114    G %
  8115   "RTN","DGR PDB",8,0)
  8116    ;
  8117   "RTN","DGR PDB",9,0)
  8118   EN ;entry  with DFN d efined.
  8119   "RTN","DGR PDB",10,0)
  8120    Q:'$D(DFN )  D HOME^ %ZIS,2^VAD PT,HDR
  8121   "RTN","DGR PDB",11,0)
  8122    D MT,AOIR ,ELIG,DIS
  8123   "RTN","DGR PDB",12,0)
  8124    N DGINS
  8125   "RTN","DGR PDB",13,0)
  8126    I $$INSUR ^IBBAPI(DF N,"","AR", .DGINS,1)
  8127   "RTN","DGR PDB",14,0)
  8128    S C="",C= $O(DGINS(" IBBAPI","I NSUR",C),- 1),C=+C+6
  8129   "RTN","DGR PDB",15,0)
  8130    D:($Y>(IO SL-C)) PAU SE,HDR:'DG QUIT Q:DGQ UIT  D INS ,PAUSE
  8131   "RTN","DGR PDB",16,0)
  8132    Q
  8133   "RTN","DGR PDB",17,0)
  8134    ;
  8135   "RTN","DGR PDB",18,0)
  8136   ELIG ;elig ibility co de(s)
  8137   "RTN","DGR PDB",19,0)
  8138    W !!," Pr imary Elig . Code: ", $P(VAEL(1) ,"^",2),"   --  ",$S( VAEL(8)']" ":"NOT VER IFIED",1:$ P(VAEL(8), "^",2))
  8139   "RTN","DGR PDB",20,0)
  8140    I VAEL(8) ]"" S Y=$S ($D(^DPT(D FN,.361)): $P(^(.361) ,"^",2),1: "") W "  "  D DT^DIQ
  8141   "RTN","DGR PDB",21,0)
  8142    ;DG*5.3*9 52 to disp lay the Ex panded MH  Care Type
  8143   "RTN","DGR PDB",22,0)
  8144    ;if patie nt's prima ry eligibi lity is EX PANDED MH  CARE NON-V ETERANS
  8145   "RTN","DGR PDB",23,0)
  8146    I +VAEL(1 )>0,$P($G( ^DIC(8,+VA EL(1),0)), "^",9)=23  W !,"Expan ded MH Car e Type: ", $$OTHSOC^D GOTHD1(^DP T(DFN,.55) )
  8147   "RTN","DGR PDB",24,0)
  8148    W !,"Othe r Elig. Co de(s): " I  $D(VAEL(1 ))>9 S I1= 0 F I=0:0  S I=$O(VAE L(1,I)) Q: 'I  S I1=I 1+1 W:I1>1  !?21 W $P (VAEL(1,I) ,"^",2)
  8149   "RTN","DGR PDB",25,0)
  8150    E  W "NO  ADDITIONAL  ELIGIBILI TIES IDENT IFIED"
  8151   "RTN","DGR PDB",26,0)
  8152    Q
  8153   "RTN","DGR PDB",27,0)
  8154    ;
  8155   "RTN","DGR PDB",28,0)
  8156   DIS ;rated  disabilit ies - Inte gration Ag reement #7 00
  8157   "RTN","DGR PDB",29,0)
  8158    ;
  8159   "RTN","DGR PDB",30,0)
  8160    ;  This i s called f rom the FE E and MCCR  package!! !
  8161   "RTN","DGR PDB",31,0)
  8162    ;
  8163   "RTN","DGR PDB",32,0)
  8164    ;  Input:   DFN as I EN of PATI ENT file
  8165   "RTN","DGR PDB",33,0)
  8166    ;           VAEL arr ay (if no  passed, it  is set) o f eligibil ity info
  8167   "RTN","DGR PDB",34,0)
  8168    ;
  8169   "RTN","DGR PDB",35,0)
  8170    I '$D(VAE L) D ELIG^ VADPT S DG KVAR=1
  8171   "RTN","DGR PDB",36,0)
  8172    W:'+VAEL( 3) !!,"  S ervice Con nected: NO " W:+VAEL( 3) !!,"          SC P ercent: ", $P(VAEL(3) ,"^",2)_"% "
  8173   "RTN","DGR PDB",37,0)
  8174    N DGQUIT
  8175   "RTN","DGR PDB",38,0)
  8176    W !," Rat ed Disabil ities: " I  'VAEL(4), $S('$D(^DG (391,+VAEL (6),0)):1, $P(^(0),"^ ",2):0,1:1 ) W "NOT A  VETERAN"  G DISQ
  8177   "RTN","DGR PDB",39,0)
  8178    S I3=0 F  I=0:0 S I= $O(^DPT(DF N,.372,I))  Q:'I!($G( DGQUIT)=1)   D
  8179   "RTN","DGR PDB",40,0)
  8180    . S I1=^( I,0),I2=$S ($D(^DIC(3 1,+I1,0)): $P(^(0),"^ ",1)_" ("_ +$P(I1,"^" ,2)_"%-"_$ S($P(I1,"^ ",3):"SC", $P(I1,"^", 3)']"":"no t specifie d",1:"NSC" )_")",1:"" ),I3=I3+1
  8181   "RTN","DGR PDB",41,0)
  8182    . I $Y>(I OSL-3) D P AUSE I $G( DGQUIT)=0  W @IOF
  8183   "RTN","DGR PDB",42,0)
  8184    . I $G(DG QUIT)=1 Q
  8185   "RTN","DGR PDB",43,0)
  8186    . W:I3>1  !?21 W I2
  8187   "RTN","DGR PDB",44,0)
  8188    W:'I3 "NO NE STATED"
  8189   "RTN","DGR PDB",45,0)
  8190   DISQ I $D( DGKVAR) D  KVAR^VADPT  K DGKVAR
  8191   "RTN","DGR PDB",46,0)
  8192    K I,I1,I2 ,I3
  8193   "RTN","DGR PDB",47,0)
  8194    Q
  8195   "RTN","DGR PDB",48,0)
  8196    ;
  8197   "RTN","DGR PDB",49,0)
  8198   INS ;insur ance infor mation
  8199   "RTN","DGR PDB",50,0)
  8200    ;
  8201   "RTN","DGR PDB",51,0)
  8202    ;  This i s called f orm the FE E package! !!
  8203   "RTN","DGR PDB",52,0)
  8204    ;
  8205   "RTN","DGR PDB",53,0)
  8206    ;  Input:   DFN as I EN of PATI ENT file
  8207   "RTN","DGR PDB",54,0)
  8208    ;           DGINSDT  as date to  compute i nsurance f lag as of  (default D T)
  8209   "RTN","DGR PDB",55,0)
  8210    ;
  8211   "RTN","DGR PDB",56,0)
  8212    Q:'$D(DFN )
  8213   "RTN","DGR PDB",57,0)
  8214    W !!,"     Health In surance: "
  8215   "RTN","DGR PDB",58,0)
  8216    S Z=$$INS UR^IBBAPI( DFN,$S($D( DGINSDT):D GINSDT,1:D T))
  8217   "RTN","DGR PDB",59,0)
  8218    W $S(Z:"Y ES",1:"NO" )
  8219   "RTN","DGR PDB",60,0)
  8220    D DISP^DG IBDSP
  8221   "RTN","DGR PDB",61,0)
  8222   INSQ K I,I 1,DGX,Z
  8223   "RTN","DGR PDB",62,0)
  8224    Q
  8225   "RTN","DGR PDB",63,0)
  8226    ;
  8227   "RTN","DGR PDB",64,0)
  8228   IN ; Old c ode
  8229   "RTN","DGR PDB",65,0)
  8230    Q
  8231   "RTN","DGR PDB",66,0)
  8232    ;
  8233   "RTN","DGR PDB",67,0)
  8234   AOIR ;Agen t Orange/i onizing ra diation
  8235   "RTN","DGR PDB",68,0)
  8236    N DGEC,NT A
  8237   "RTN","DGR PDB",69,0)
  8238    S DGX=$S( $D(^DPT(DF N,.321)):^ (.321),1:" ")
  8239   "RTN","DGR PDB",70,0)
  8240    F I=2,3 S  X=$P(DGX, "^",I) W:I =2 !,"            A/O  Exp.: " W :I=3 "ION  Rad.: " W  $S(X="Y":" YES",X="N" :"NO",X="U ":"UNKNOWN ",1:"NOT A NSWERED"), "   "
  8241   "RTN","DGR PDB",71,0)
  8242    S X=$G(^D PT(DFN,.38 )),X1=$P(X ,"^",1) W  "Medicaid  Elig: ",$S (X1="":"NO T ANSWERED ",'X1:"NO" ,1:"YES")  I ($X+15)' >IOM W " -  " S Y=$P( X,"^",2) D  D^DIQ W $ P(Y,"@")
  8243   "RTN","DGR PDB",72,0)
  8244    S DGEC=$S ($D(^DPT(D FN,.322)): ^DPT(DFN,. 322),1:"")
  8245   "RTN","DGR PDB",73,0)
  8246    S X=$P(DG EC,U,13) W  !,"         Env Cont am.: " W $ S(X="Y":"Y ES",X="N": "NO",X="U" :"UNKNOWN" ,1:"NOT AN SWERED"),"    "
  8247   "RTN","DGR PDB",74,0)
  8248    S NTA=$S( $$GETCUR^D GNTAPI(DFN ,"DGNTARR" )>0:DGNTAR R("INTRP") ,1:"")
  8249   "RTN","DGR PDB",75,0)
  8250    K DGNTARR
  8251   "RTN","DGR PDB",76,0)
  8252    W "N/T Ra dium: " W  $S(NTA'="" :NTA,1:"NO T ANSWERED ")
  8253   "RTN","DGR PDB",77,0)
  8254    Q
  8255   "RTN","DGR PDB",78,0)
  8256    ;
  8257   "RTN","DGR PDB",79,0)
  8258   PAUSE F J= 1:1 Q:($Y> (IOSL-3))   W !
  8259   "RTN","DGR PDB",80,0)
  8260    S DGX1=""  I $E(IOST ,1,2)["C-"  N DIR S D IR(0)="E"  D ^DIR S D GQUIT='Y
  8261   "RTN","DGR PDB",81,0)
  8262    Q
  8263   "RTN","DGR PDB",82,0)
  8264    ;
  8265   "RTN","DGR PDB",83,0)
  8266   HDR ;Scree n Header
  8267   "RTN","DGR PDB",84,0)
  8268    W @IOF I  $P(VAEL(6) ,"^",2)]""  S DGTYPE= $P(VAEL(6) ,"^",2)
  8269   "RTN","DGR PDB",85,0)
  8270    W $P(VADM (1),"^",1) ,?32,VA("P ID"),?47,$ P(VADM(3), "^",2) S X =$S($D(DGT YPE):$P(DG TYPE,"^",1 ),1:"PATIE NT TYPE UN KNOWN"),X1 =79-$L(X)  W ?X1,X
  8271   "RTN","DGR PDB",86,0)
  8272    S X="",$P (X,"=",80) ="" W !,X  Q
  8273   "RTN","DGR PDB",87,0)
  8274    Q
  8275   "RTN","DGR PDB",88,0)
  8276    ;
  8277   "RTN","DGR PDB",89,0)
  8278   MT I '$O(^ DGMT(408.3 1,"AD",1,D FN,0)) W ! ,"  Means  Test Statu s:  NOT IN  MEANS TES T FILE" Q
  8279   "RTN","DGR PDB",90,0)
  8280    ;if patie nt is on a  DOM ward,  don't dis play Means  Test requ ired messa ge
  8281   "RTN","DGR PDB",91,0)
  8282    D DOM^DGM TR D:'$G(D GDOM) DIS^ DGMTU(DFN)  K DGDOM
  8283   "RTN","DGR PDB",92,0)
  8284    Q
  8285   "RTN","DGR PDB",93,0)
  8286    ;
  8287   "RTN","DGR PDB",94,0)
  8288   END D KVAR ^VADPT
  8289   "RTN","DGR PDB",95,0)
  8290    K A,C,I,I 1,I2,I3,J, DIC,DIR,DF N,DGA1,DGM T,DGMTL,DG MTLA,DGX,D GX1,DGT,DG TYPE,DGQUI T,DGMTLL,X ,X1,VAROOT ,VA,Y,Z
  8291   "RTN","DGR PDB",96,0)
  8292    Q
  8293   "RTN","DGR PDB",97,0)
  8294    ;
  8295   "RTN","DGR PDB",98,0)
  8296   RDIS(DGDFN ,DGARR) ;A PI to retu rn all Rat ed Disabil ities from  the 
  8297   "RTN","DGR PDB",99,0)
  8298    ;Patient  file for a  patient u sing an ar ray.  Retu rned in de scending S ervice Con nected per cent.
  8299   "RTN","DGR PDB",100,0 )
  8300    ;
  8301   "RTN","DGR PDB",101,0 )
  8302    ; Integra tion Agree ment #4807
  8303   "RTN","DGR PDB",102,0 )
  8304    ; 
  8305   "RTN","DGR PDB",103,0 )
  8306    ;Input           DGD FN - IEN o f patient  file (requ ired)
  8307   "RTN","DGR PDB",104,0 )
  8308    ;Input/Ou tput   DGA RR - name  of array f or returne d disabili ty info (r equired)
  8309   "RTN","DGR PDB",105,0 )
  8310    ;                pie ce 1 - Dis ability IE N (in file  31)
  8311   "RTN","DGR PDB",106,0 )
  8312    ;                pie ce 2 - Dis ability %
  8313   "RTN","DGR PDB",107,0 )
  8314    ;                pie ce 3 - SC?  (1,0)
  8315   "RTN","DGR PDB",108,0 )
  8316    ;                pie ce 4 - ext remity aff ected
  8317   "RTN","DGR PDB",109,0 )
  8318    ;                pie ce 5 - ori ginal effe ctive date
  8319   "RTN","DGR PDB",110,0 )
  8320    ;                pie ce 6 - cur rent effec tive date
  8321   "RTN","DGR PDB",111,0 )
  8322    ;Output 1 =successfu l and arra y returned  with data
  8323   "RTN","DGR PDB",112,0 )
  8324    ;       0 =unsuccess ful and no  array
  8325   "RTN","DGR PDB",113,0 )
  8326    ;          
  8327   "RTN","DGR PDB",114,0 )
  8328    N DGARR1, DGC,DGCC,D GERR,DGNOD E,DGCT,DGE ,DGEE
  8329   "RTN","DGR PDB",115,0 )
  8330    K DGW,DGA RR
  8331   "RTN","DGR PDB",116,0 )
  8332    I $G(DGDF N)']"" Q 0
  8333   "RTN","DGR PDB",117,0 )
  8334    I '$D(^DP T(DGDFN,0) ) Q 0
  8335   "RTN","DGR PDB",118,0 )
  8336    D GETS^DI Q(2,DGDFN, ".3721*"," I","DGARR1 ","DGERR")
  8337   "RTN","DGR PDB",119,0 )
  8338    I $D(DGER R) Q 0
  8339   "RTN","DGR PDB",120,0 )
  8340    S DGCC=0
  8341   "RTN","DGR PDB",121,0 )
  8342    S DGCC=$O (^DPT(DGDF N,.372,DGC C))
  8343   "RTN","DGR PDB",122,0 )
  8344    I 'DGCC Q  0
  8345   "RTN","DGR PDB",123,0 )
  8346    S DGC=""
  8347   "RTN","DGR PDB",124,0 )
  8348    F  S DGC= $O(DGARR1( 2.04,DGC))  Q:DGC']""   D
  8349   "RTN","DGR PDB",125,0 )
  8350    . S DGNOD E=DGC
  8351   "RTN","DGR PDB",126,0 )
  8352    . S DGARR (DGC)=DGAR R1(2.04,DG NODE,.01," I")_"^"_DG ARR1(2.04, DGNODE,2," I")_"^"_DG ARR1(2.04, DGNODE,3," I")_"^"_DG ARR1(2.04, DGNODE,4," I")_"^"_DG ARR1(2.04, DGNODE,5," I")_"^"_DG ARR1(2.04, DGNODE,6," I")
  8353   "RTN","DGR PDB",127,0 )
  8354    S DGE=""
  8355   "RTN","DGR PDB",128,0 )
  8356    F  S DGE= $O(DGARR(D GE)) Q:'DG E  D
  8357   "RTN","DGR PDB",129,0 )
  8358    . I $P(DG ARR(DGE),U ,2)="" S $ P(DGARR(DG E),U,2)=0
  8359   "RTN","DGR PDB",130,0 )
  8360    . S DGW($ P(DGARR(DG E),U,2),$P (DGE,",",1 ))=DGARR(D GE)
  8361   "RTN","DGR PDB",131,0 )
  8362    S DGE="", DGCT=1
  8363   "RTN","DGR PDB",132,0 )
  8364    K DGARR
  8365   "RTN","DGR PDB",133,0 )
  8366    F  S DGE= $O(DGW(DGE ),-1) Q:DG E']""  D
  8367   "RTN","DGR PDB",134,0 )
  8368    . F DGEE= 0:0 S DGEE =$O(DGW(DG E,DGEE)) Q :DGEE'>0   D
  8369   "RTN","DGR PDB",135,0 )
  8370    . . S DGA RR(DGCT)=D GW(DGE,DGE E) S DGCT= DGCT+1
  8371   "RTN","DGR PDB",136,0 )
  8372    K DGW
  8373   "RTN","DGR PDB",137,0 )
  8374    Q 1
  8375   "RTN","DGR PDB",138,0 )
  8376    ;
  8377   "SEC","^DI C",33,33,0 ,"AUDIT")
  8378   @
  8379   "SEC","^DI C",33,33,0 ,"DD")
  8380   @
  8381   "SEC","^DI C",33,33,0 ,"DEL")
  8382   @
  8383   "SEC","^DI C",33,33,0 ,"LAYGO")
  8384   @
  8385   "SEC","^DI C",33,33,0 ,"RD")
  8386   @
  8387   "SEC","^DI C",33,33,0 ,"WR")
  8388   @
  8389   "SEC","^DI C",33.1,33 .1,0,"AUDI T")
  8390   @
  8391   "SEC","^DI C",33.1,33 .1,0,"DD")
  8392   @
  8393   "SEC","^DI C",33.1,33 .1,0,"DEL" )
  8394   @
  8395   "SEC","^DI C",33.1,33 .1,0,"LAYG O")
  8396   @
  8397   "SEC","^DI C",33.1,33 .1,0,"RD")
  8398   @
  8399   "SEC","^DI C",33.1,33 .1,0,"WR")
  8400   @
  8401   "VER")
  8402   8.0^22.2
  8403   "^DD",2,2, .5501,0)
  8404   EXPANDED M H CARE TYP E^RS^OTH-9 0:EMERGENT  MH OTH;OT H-CMBT:COM BAT MH OTH ;OTH-MST:M ST MH OTH; ^.55;1^Q
  8405   "^DD",2,2, .5501,3)
  8406   Enter the  expanded m ental heal th care ty pe justify ing the EX PANDED MH  CARE eligi bility rul ing.
  8407   "^DD",2,2, .5501,21,0 )
  8408   ^^2^2^3190 208^
  8409   "^DD",2,2, .5501,21,1 ,0)
  8410   This field  stores th e EXPANDED  MH CARE T YPE which  indicates  the expand ed 
  8411   "^DD",2,2, .5501,21,2 ,0)
  8412   emergent h ealth care  authority  that the  patient sh ould be tr eated unde r.
  8413   "^DD",2,2, .5501,23,0 )
  8414   ^^2^2^3190 208^
  8415   "^DD",2,2, .5501,23,1 ,0)
  8416   The value  stored in  this field  should ma tch the el igibility  factor typ
  8417   "^DD",2,2, .5501,23,2 ,0)
  8418   set up in  the Enroll ment syste m.
  8419   "^DD",2,2, .5501,"DT" )
  8420   3190318
  8421   "^DD",33,3 3,0)
  8422   FIELD^^2^8
  8423   "^DD",33,3 3,0,"DT")
  8424   3190315
  8425   "^DD",33,3 3,0,"IX"," B",33,.01)
  8426  
  8427   "^DD",33,3 3,0,"NM"," OTH ELIGIB ILITY CLOC K")
  8428  
  8429   "^DD",33,3 3,0,"PT",3 3.1,.01)
  8430  
  8431   "^DD",33,3 3,0,"VRPK" )
  8432   DG
  8433   "^DD",33,3 3,.01,0)
  8434   PATIENT^RP 2'^DPT(^0; 1^Q
  8435   "^DD",33,3 3,.01,1,0)
  8436   ^.1
  8437   "^DD",33,3 3,.01,1,1, 0)
  8438   33^B
  8439   "^DD",33,3 3,.01,1,1, 1)
  8440   S ^DGOTH(3 3,"B",$E(X ,1,30),DA) =""
  8441   "^DD",33,3 3,.01,1,1, 2)
  8442   K ^DGOTH(3 3,"B",$E(X ,1,30),DA)
  8443   "^DD",33,3 3,.01,3)
  8444   Select the  patient w ith OTH el igibility  clock.
  8445   "^DD",33,3 3,.01,21,0 )
  8446   ^.001^2^2^ 3180207^^
  8447   "^DD",33,3 3,.01,21,1 ,0)
  8448   Patient wi th OTH 90  DAYS ELIGI BILITY tha t receives  mental he alth care  in 
  8449   "^DD",33,3 3,.01,21,2 ,0)
  8450   the VA fac ility.
  8451   "^DD",33,3 3,.01,23,0 )
  8452   ^.001^1^1^ 3180207^^^ ^
  8453   "^DD",33,3 3,.01,23,1 ,0)
  8454   Pointer to  the PATIE NT file (# 2).
  8455   "^DD",33,3 3,.01,"DT" )
  8456   3190307
  8457   "^DD",33,3 3,.02,0)
  8458   OTH STATUS ^S^0:INACT IVE;1:ACTI VE;^0;2^Q
  8459   "^DD",33,3 3,.02,3)
  8460   Enter stat us of the  OTH clock  for the pa tient.
  8461   "^DD",33,3 3,.02,21,0 )
  8462   ^.001^1^1^ 3180206^^
  8463   "^DD",33,3 3,.02,21,1 ,0)
  8464   The curren t status o f the OTH  clock for  the patien t.
  8465   "^DD",33,3 3,.02,"DT" )
  8466   3190307
  8467   "^DD",33,3 3,.03,0)
  8468   LAST OTH S TATUS CHAN GE DATE^D^ ^0;3^S %DT ="ESTX" D  ^%DT S X=Y  K:Y<1 X
  8469   "^DD",33,3 3,.03,3)
  8470   Enter the  reactivati on/inactiv ation date  for the O TH patient .
  8471   "^DD",33,3 3,.03,21,0 )
  8472   ^^2^2^3190 227^
  8473   "^DD",33,3 3,.03,21,1 ,0)
  8474   This field  captures  the reacti vation/ina ctivation  of the Oth er Than 
  8475   "^DD",33,3 3,.03,21,2 ,0)
  8476   Honorable  countdown  clock.
  8477   "^DD",33,3 3,.03,"DT" )
  8478   3190307
  8479   "^DD",33,3 3,.04,0)
  8480   LAST OTH S TATUS CHAN GE REASON^ FJ60^^0;4^ K:$L(X)>60 !($L(X)<1)  X
  8481   "^DD",33,3 3,.04,3)
  8482   Enter the  reason for  inactivat ion/reacti vation of  the OTH pa tient's co untdown cl ock. Answe r must be  1 to 60 ch aracters i n length.
  8483   "^DD",33,3 3,.04,21,0 )
  8484   ^^2^2^3190 227^
  8485   "^DD",33,3 3,.04,21,1 ,0)
  8486   This field  will capt ure the re ason/comme nt for rea ctivation/ inactivati on 
  8487   "^DD",33,3 3,.04,21,2 ,0)
  8488   of the Oth er Than Ho norable pa tient coun tdown cloc k.
  8489   "^DD",33,3 3,.04,"DT" )
  8490   3190307
  8491   "^DD",33,3 3,.05,0)
  8492   VBA ADJUDI CATION SOU RCE^S^1:VB A Adjudica tion Lette r/Email Re ceived by  Registrati on Staff;2 :VBA Adjud ication Le tter Recei ved by the  Patient;3 :Other;^0; 5^Q
  8493   "^DD",33,3 3,.05,3)
  8494   Enter the  source of  informatio n of the V BA Adjucat ion for th e OTH pati ent.
  8495   "^DD",33,3 3,.05,21,0 )
  8496   ^^2^2^3190 227^
  8497   "^DD",33,3 3,.05,21,1 ,0)
  8498   This field  captures  the source  of inform ation of t he VBA Adj udication  for 
  8499   "^DD",33,3 3,.05,21,2 ,0)
  8500   the Other  Than Honor able patie nt.
  8501   "^DD",33,3 3,.05,"DT" )
  8502   3190227
  8503   "^DD",33,3 3,.06,0)
  8504   VBA ADJUDI CATION DAT E^D^^0;6^S  %DT="EX"  D ^%DT S X =Y K:X<1 X
  8505   "^DD",33,3 3,.06,3)
  8506   Enter the  actual VBA  Adjudicat ion Date f or the OTH  Patient.
  8507   "^DD",33,3 3,.06,21,0 )
  8508   ^^3^3^3180 705^
  8509   "^DD",33,3 3,.06,21,1 ,0)
  8510   This field  capture t he actual  VBA Adjudi cation Dat e for the  Other Than  
  8511   "^DD",33,3 3,.06,21,2 ,0)
  8512   Honorable  patient. E ntering a  date in th is field i nactivate  the patien t's 
  8513   "^DD",33,3 3,.06,21,3 ,0)
  8514   countdown  clock.
  8515   "^DD",33,3 3,.06,"DT" )
  8516   3180705
  8517   "^DD",33,3 3,1,0)
  8518   OTH 365 DA YS CLOCK^3 3.01^^1;0
  8519   "^DD",33,3 3,1,21,0)
  8520   ^.001^1^1^ 3190227^^^ ^
  8521   "^DD",33,3 3,1,21,1,0 )
  8522   This multi ple contai ns data fo r tracking  365 days  clock stat us.
  8523   "^DD",33,3 3,1,"DT")
  8524   3180207
  8525   "^DD",33,3 3,2,0)
  8526   ELIGIBILIT Y CHANGES^ 33.02DA^^2 ;0
  8527   "^DD",33,3 3,2,21,0)
  8528   ^^1^1^3190 307^
  8529   "^DD",33,3 3,2,21,1,0 )
  8530   This multi ple contai ns history  of OTH el igibility  changes.
  8531   "^DD",33,3 3.01,0)
  8532   OTH 365 DA YS CLOCK S UB-FIELD^^ .02^3
  8533   "^DD",33,3 3.01,0,"DT ")
  8534   3190304
  8535   "^DD",33,3 3.01,0,"IX ","B",33.0 1,.01)
  8536  
  8537   "^DD",33,3 3.01,0,"NM ","OTH 365  DAYS CLOC K")
  8538  
  8539   "^DD",33,3 3.01,0,"UP ")
  8540   33
  8541   "^DD",33,3 3.01,.01,0 )
  8542   365 DAYS P ERIOD NUMB ER^MNJ3,0^ ^0;1^K:+X' =X!(X>100) !(X<1)!(X? .E1"."1.N)  X
  8543   "^DD",33,3 3.01,.01,1 ,0)
  8544   ^.1
  8545   "^DD",33,3 3.01,.01,1 ,1,0)
  8546   33.01^B
  8547   "^DD",33,3 3.01,.01,1 ,1,1)
  8548   S ^DGOTH(3 3,DA(1),1, "B",$E(X,1 ,30),DA)=" "
  8549   "^DD",33,3 3.01,.01,1 ,1,2)
  8550   K ^DGOTH(3 3,DA(1),1, "B",$E(X,1 ,30),DA)
  8551   "^DD",33,3 3.01,.01,3 )
  8552   Type a num ber betwee n 1 and 10 0, 0 decim al digits.
  8553   "^DD",33,3 3.01,.01,2 1,0)
  8554   ^^2^2^3180 207^
  8555   "^DD",33,3 3.01,.01,2 1,1,0)
  8556   This the s equential  number of  the OTH el igibility  365 days c lock for 
  8557   "^DD",33,3 3.01,.01,2 1,2,0)
  8558   the patien t.
  8559   "^DD",33,3 3.01,.01," DT")
  8560   3190227
  8561   "^DD",33,3 3.01,.02,0 )
  8562   START DATE ^D^^0;2^S  %DT="EX" D  ^%DT S X= Y K:Y<1 X
  8563   "^DD",33,3 3.01,.02,3 )
  8564   Enter the  date when  the 365 da ys clock s tarted.
  8565   "^DD",33,3 3.01,.02,2 1,0)
  8566   ^.001^1^1^ 3180206^^^
  8567   "^DD",33,3 3.01,.02,2 1,1,0)
  8568   Date when  the 365 da ys clock s tarted.
  8569   "^DD",33,3 3.01,.02," DT")
  8570   3180206
  8571   "^DD",33,3 3.01,1,0)
  8572   OTH 90 DAY S CLOCK^33 .11^^1;0
  8573   "^DD",33,3 3.01,1,21, 0)
  8574   ^.001^1^1^ 3190227^^^ ^
  8575   "^DD",33,3 3.01,1,21, 1,0)
  8576   This multi ple contai ns data fo r tracking  90 days c lock statu s.
  8577   "^DD",33,3 3.01,1,"DT ")
  8578   3180207
  8579   "^DD",33,3 3.02,0)
  8580   ELIGIBILIT Y CHANGES  SUB-FIELD^ ^.07^7
  8581   "^DD",33,3 3.02,0,"DT ")
  8582   3190307
  8583   "^DD",33,3 3.02,0,"IX ","B",33.0 2,.01)
  8584  
  8585   "^DD",33,3 3.02,0,"NM ","ELIGIBI LITY CHANG ES")
  8586  
  8587   "^DD",33,3 3.02,0,"UP ")
  8588   33
  8589   "^DD",33,3 3.02,.01,0 )
  8590   DATE OF CH ANGE^D^^0; 1^S %DT="E STXR" D ^% DT S X=Y K :X<1 X
  8591   "^DD",33,3 3.02,.01,1 ,0)
  8592   ^.1
  8593   "^DD",33,3 3.02,.01,1 ,1,0)
  8594   33.02^B
  8595   "^DD",33,3 3.02,.01,1 ,1,1)
  8596   S ^DGOTH(3 3,DA(1),2, "B",$E(X,1 ,30),DA)=" "
  8597   "^DD",33,3 3.02,.01,1 ,1,2)
  8598   K ^DGOTH(3 3,DA(1),2, "B",$E(X,1 ,30),DA)
  8599   "^DD",33,3 3.02,.01,3 )
  8600   Enter the  date of th is eligibi lity chang e.
  8601   "^DD",33,3 3.02,.01,2 1,0)
  8602   ^^1^1^3190 307^
  8603   "^DD",33,3 3.02,.01,2 1,1,0)
  8604   Date of th e eligibil ity change .
  8605   "^DD",33,3 3.02,.01," DT")
  8606   3190307
  8607   "^DD",33,3 3.02,.02,0 )
  8608   ELIGIBILIT Y CODE^P8' ^DIC(8,^0; 2^Q
  8609   "^DD",33,3 3.02,.02,3 )
  8610   Select eli gibility c ode.
  8611   "^DD",33,3 3.02,.02,2 1,0)
  8612   ^^1^1^3190 307^
  8613   "^DD",33,3 3.02,.02,2 1,1,0)
  8614   New eligib ility code  for this  patient.
  8615   "^DD",33,3 3.02,.02," DT")
  8616   3190307
  8617   "^DD",33,3 3.02,.03,0 )
  8618   ELIGIBILIT Y FACTOR T YPE^S^OTH- 90:EMERGEN T MH OTH;O TH-COMBAT: COMBAT MH  OTH;OTH-MS T:MST MH O TH;^0;3^Q
  8619   "^DD",33,3 3.02,.03,3 )
  8620   Select eli gibility f actor type .
  8621   "^DD",33,3 3.02,.03,2 1,0)
  8622   ^^1^1^3190 307^
  8623   "^DD",33,3 3.02,.03,2 1,1,0)
  8624   Eligibilit y factor t ype for OT H eligibil ities.
  8625   "^DD",33,3 3.02,.03,2 3,0)
  8626   ^^1^1^3190 307^
  8627   "^DD",33,3 3.02,.03,2 3,1,0)
  8628   Same set o f codes as  field 2/. 5501
  8629   "^DD",33,3 3.02,.03," DT")
  8630   3190307
  8631   "^DD",33,3 3.02,.04,0 )
  8632   CHANGE REA SON^S^0:IN ITIAL REGI STRATION;1 :VBA ADJUD ICATION;2: OTH AUTHOR ITY CHANGE ;3:CORRECT ION;^0;4^Q
  8633   "^DD",33,3 3.02,.04,3 )
  8634   Select rea son for th is eligibi lity chang e.
  8635   "^DD",33,3 3.02,.04,2 1,0)
  8636   ^^1^1^3190 307^
  8637   "^DD",33,3 3.02,.04,2 1,1,0)
  8638   Reason for  this elig ibility ch ange.
  8639   "^DD",33,3 3.02,.04," DT")
  8640   3190307
  8641   "^DD",33,3 3.02,.05,0 )
  8642   COMMENT^FJ 60^^0;5^K: $L(X)>60!( $L(X)<1) X
  8643   "^DD",33,3 3.02,.05,3 )
  8644   Answer mus t be 1-60  characters  in length .
  8645   "^DD",33,3 3.02,.05,2 1,0)
  8646   ^^1^1^3190 307^
  8647   "^DD",33,3 3.02,.05,2 1,1,0)
  8648   Comment fo r this eli gibility c hange.
  8649   "^DD",33,3 3.02,.05," DT")
  8650   3190307
  8651   "^DD",33,3 3.02,.06,0 )
  8652   ENTERED BY ^FJ60^^0;6 ^K:$L(X)>6 0!($L(X)<5 ) X
  8653   "^DD",33,3 3.02,.06,3 )
  8654   Answer mus t be 5-60  characters  in length .
  8655   "^DD",33,3 3.02,.06,2 1,0)
  8656   ^^1^1^3190 307^
  8657   "^DD",33,3 3.02,.06,2 1,1,0)
  8658   Name of th e person w ho changed  eligibili ty for thi s patient.
  8659   "^DD",33,3 3.02,.06," DT")
  8660   3190307
  8661   "^DD",33,3 3.02,.07,0 )
  8662   FACILITY^P 4'^DIC(4,^ 0;7^Q
  8663   "^DD",33,3 3.02,.07,3 )
  8664   Select fac ility wher e this eli gibility c hange was  made.
  8665   "^DD",33,3 3.02,.07,2 1,0)
  8666   ^^2^2^3190 307^
  8667   "^DD",33,3 3.02,.07,2 1,1,0)
  8668   Facility w here this  eligibilit y change w as made. T his field  being blan
  8669   "^DD",33,3 3.02,.07,2 1,2,0)
  8670   means that  change or iginated f rom Enroll ment Syste m.
  8671   "^DD",33,3 3.02,.07," DT")
  8672   3190307
  8673   "^DD",33,3 3.11,0)
  8674   OTH 90 DAY S CLOCK SU B-FIELD^^. 1^10
  8675   "^DD",33,3 3.11,0,"DT ")
  8676   3190315
  8677   "^DD",33,3 3.11,0,"IX ","B",33.1 1,.01)
  8678  
  8679   "^DD",33,3 3.11,0,"NM ","OTH 90  DAYS CLOCK ")
  8680  
  8681   "^DD",33,3 3.11,0,"UP ")
  8682   33.01
  8683   "^DD",33,3 3.11,.01,0 )
  8684   90 DAYS PE RIOD NUMBE R^MNJ2,0^^ 0;1^K:+X'= X!(X>99)!( X<1)!(X?.E 1"."1.N) X
  8685   "^DD",33,3 3.11,.01,1 ,0)
  8686   ^.1
  8687   "^DD",33,3 3.11,.01,1 ,1,0)
  8688   33.11^B
  8689   "^DD",33,3 3.11,.01,1 ,1,1)
  8690   S ^DGOTH(3 3,DA(2),1, DA(1),1,"B ",$E(X,1,3 0),DA)=""
  8691   "^DD",33,3 3.11,.01,1 ,1,2)
  8692   K ^DGOTH(3 3,DA(2),1, DA(1),1,"B ",$E(X,1,3 0),DA)
  8693   "^DD",33,3 3.11,.01,3 )
  8694   Type a num ber betwee n 1 and 99 , 0 decima l digits.
  8695   "^DD",33,3 3.11,.01,2 1,0)
  8696   ^^2^2^3180 207^
  8697   "^DD",33,3 3.11,.01,2 1,1,0)
  8698   This the s equential  number of  the OTH el igibility  90 days cl ock for 
  8699   "^DD",33,3 3.11,.01,2 1,2,0)
  8700   the patien t.
  8701   "^DD",33,3 3.11,.01," DT")
  8702   3190227
  8703   "^DD",33,3 3.11,.02,0 )
  8704   START DATE ^D^^0;2^S  %DT="EX" D  ^%DT S X= Y K:Y<1 X
  8705   "^DD",33,3 3.11,.02,3 )
  8706   Enter the  date when  the 90 day s clock st arted.
  8707   "^DD",33,3 3.11,.02,2 1,0)
  8708   ^^3^3^3180 327^
  8709   "^DD",33,3 3.11,.02,2 1,1,0)
  8710   The date w hen the 90  days cloc k started.
  8711   "^DD",33,3 3.11,.02,2 1,2,0)
  8712   A future d ate cannot  be entere d and cann ot be more  than 90 d ays in the
  8713   "^DD",33,3 3.11,.02,2 1,3,0)
  8714   past.
  8715   "^DD",33,3 3.11,.02," DT")
  8716   3180411
  8717   "^DD",33,3 3.11,.03,0 )
  8718   AUTHORIZAT ION ENTERE D BY^FJ60^ ^0;3^K:$L( X)>60!($L( X)<5) X
  8719   "^DD",33,3 3.11,.03,3 )
  8720   Answer mus t be 5-60  characters  in length .
  8721   "^DD",33,3 3.11,.03,2 1,0)
  8722   ^^1^1^3190 301^^^
  8723   "^DD",33,3 3.11,.03,2 1,1,0)
  8724   The user w ho entered  the autho rization f or the 90  days perio d.
  8725   "^DD",33,3 3.11,.03," DT")
  8726   3190301
  8727   "^DD",33,3 3.11,.04,0 )
  8728   AUTHORIZAT ION RECEIV ED DATE^RD ^^0;4^S %D T="ESTX" D  ^%DT S X= Y K:X<1 X
  8729   "^DD",33,3 3.11,.04,3 )
  8730   Enter a da te when th e authoriz ation was  signed.
  8731   "^DD",33,3 3.11,.04,2 1,0)
  8732   ^^1^1^3190 315^^
  8733   "^DD",33,3 3.11,.04,2 1,1,0)
  8734   The date w hen the ad ditional 9 0 days per iod was au thorized.
  8735   "^DD",33,3 3.11,.04," DT")
  8736   3190315
  8737   "^DD",33,3 3.11,.05,0 )
  8738   ENTERED OR  EDITED BY ^FJ60^^0;5 ^K:$L(X)>6 0!($L(X)<5 ) X
  8739   "^DD",33,3 3.11,.05,3 )
  8740   Answer mus t be 5-60  characters  in length .
  8741   "^DD",33,3 3.11,.05,2 1,0)
  8742   ^^1^1^3190 301^^
  8743   "^DD",33,3 3.11,.05,2 1,1,0)
  8744   The user w ho created  or edited  last time  the 90 da ys clock.
  8745   "^DD",33,3 3.11,.05," DT")
  8746   3190301
  8747   "^DD",33,3 3.11,.06,0 )
  8748   DATE ENTER ED OR EDIT ED^D^^0;6^ S %DT="EST X" D ^%DT  S X=Y K:Y< 1 X
  8749   "^DD",33,3 3.11,.06,3 )
  8750   Enter the  date and t ime when t he 90 days  clock was  entered o r edited l ast time.
  8751   "^DD",33,3 3.11,.06,2 1,0)
  8752   ^^1^1^3180 206^
  8753   "^DD",33,3 3.11,.06,2 1,1,0)
  8754   The date a nd time wh en the 90  days clock  was enter ed or edit ed last ti me.
  8755   "^DD",33,3 3.11,.06," DT")
  8756   3180206
  8757   "^DD",33,3 3.11,.07,0 )
  8758   AUTHORIZED  BY^RFJ60^ ^0;7^K:$L( X)>60!($L( X)<5) X
  8759   "^DD",33,3 3.11,.07,. 009,1,0)
  8760   ENTER FROM  1 TO 60 C HARACTERS  OF FREE TE XT
  8761   "^DD",33,3 3.11,.07,3 )
  8762   Answer mus t be 5-60  characters  in length .
  8763   "^DD",33,3 3.11,.07,2 1,0)
  8764   ^^1^1^3190 301^^^
  8765   "^DD",33,3 3.11,.07,2 1,1,0)
  8766   The person  who appro ved and au thorized t he second  day period .
  8767   "^DD",33,3 3.11,.07," DT")
  8768   3190301
  8769   "^DD",33,3 3.11,.08,0 )
  8770   FACILITY^P 4'^DIC(4,^ 0;8^Q
  8771   "^DD",33,3 3.11,.08,3 )
  8772   Select the  facility  where this  period wa s started.
  8773   "^DD",33,3 3.11,.08,2 1,0)
  8774   ^^1^1^3190 304^
  8775   "^DD",33,3 3.11,.08,2 1,1,0)
  8776   Facility w here this  90-day per iod was st arted.
  8777   "^DD",33,3 3.11,.08," DT")
  8778   3190304
  8779   "^DD",33,3 3.11,.09,0 )
  8780   AUTHORIZAT ION COMMEN T^FJ60^^0; 9^K:$L(X)> 60!($L(X)< 1) X
  8781   "^DD",33,3 3.11,.09,3 )
  8782   Answer mus t be 1-60  characters  in length .
  8783   "^DD",33,3 3.11,.09,2 1,0)
  8784   ^^1^1^3190 314^
  8785   "^DD",33,3 3.11,.09,2 1,1,0)
  8786   Comment is  required  if authori zation was  not provi ded.
  8787   "^DD",33,3 3.11,.09," DT")
  8788   3190314
  8789   "^DD",33,3 3.11,.1,0)
  8790   DATE REQUE ST SUBMITT ED^D^^0;10 ^S %DT="ES TX" D ^%DT  S X=Y K:Y <1 X
  8791   "^DD",33,3 3.11,.1,3)
  8792   Enter the  date of au thorizatio n request  submission .
  8793   "^DD",33,3 3.11,.1,21 ,0)
  8794   ^^1^1^3190 227^
  8795   "^DD",33,3 3.11,.1,21 ,1,0)
  8796   Date of au thorizatio n request  submission  for this  90 day per iod.
  8797   "^DD",33,3 3.11,.1,"D T")
  8798   3190227
  8799   "^DD",33.1 ,33.1,0)
  8800   FIELD^^1^2
  8801   "^DD",33.1 ,33.1,0,"D T")
  8802   3190315
  8803   "^DD",33.1 ,33.1,0,"I X","B",33. 1,.01)
  8804  
  8805   "^DD",33.1 ,33.1,0,"N M","OTH CL OCK HISTOR Y")
  8806  
  8807   "^DD",33.1 ,33.1,0,"V RPK")
  8808   DG
  8809   "^DD",33.1 ,33.1,.01, 0)
  8810   OTH CLOCK^ RP33^DGOTH (33,^0;1^Q
  8811   "^DD",33.1 ,33.1,.01, 1,0)
  8812   ^.1
  8813   "^DD",33.1 ,33.1,.01, 1,1,0)
  8814   33.1^B
  8815   "^DD",33.1 ,33.1,.01, 1,1,1)
  8816   S ^DGOTH(3 3.1,"B",$E (X,1,30),D A)=""
  8817   "^DD",33.1 ,33.1,.01, 1,1,2)
  8818   K ^DGOTH(3 3.1,"B",$E (X,1,30),D A)
  8819   "^DD",33.1 ,33.1,.01, 3)
  8820   Enter the  Other Than  Honorable  patient n ame whom y ou would l ike to vie w audit hi story chan ges.
  8821   "^DD",33.1 ,33.1,.01, 21,0)
  8822   ^^2^2^3180 813^
  8823   "^DD",33.1 ,33.1,.01, 21,1,0)
  8824   This field  contains  the name o f the pati ent whose  Other Than  Honorable  
  8825   "^DD",33.1 ,33.1,.01, 21,2,0)
  8826   demographi c informat ion has be en modifie d.
  8827   "^DD",33.1 ,33.1,.01, 23,0)
  8828   ^.001^1^1^ 3180425^^^
  8829   "^DD",33.1 ,33.1,.01, 23,1,0)
  8830   The pointe r to the O TH ELIGIBI LITY CLOCK  FILE (#33 ).
  8831   "^DD",33.1 ,33.1,.01, "DT")
  8832   3180813
  8833   "^DD",33.1 ,33.1,1,0)
  8834   HISTORY RE CORD^33.12 ^^1;0
  8835   "^DD",33.1 ,33.1,1,21 ,0)
  8836   ^.001^2^2^ 3180425^^
  8837   "^DD",33.1 ,33.1,1,21 ,1,0)
  8838   This multi ple stored  records o f changes  made for c ertain fie lds of the  
  8839   "^DD",33.1 ,33.1,1,21 ,2,0)
  8840   OTH ELIGIB ILITY CLOC K FILE (#3 3).
  8841   "^DD",33.1 ,33.12,0)
  8842   HISTORY RE CORD SUB-F IELD^^.08^ 8
  8843   "^DD",33.1 ,33.12,0," DT")
  8844   3190315
  8845   "^DD",33.1 ,33.12,0," IX","B",33 .12,.01)
  8846  
  8847   "^DD",33.1 ,33.12,0," NM","HISTO RY RECORD" )
  8848  
  8849   "^DD",33.1 ,33.12,0," UP")
  8850   33.1
  8851   "^DD",33.1 ,33.12,.01 ,0)
  8852   365 DAYS P ERIOD^MNJ2 ,0^^0;1^K: +X'=X!(X>9 9)!(X<1)!( X?.E1"."1N .N) X
  8853   "^DD",33.1 ,33.12,.01 ,1,0)
  8854   ^.1
  8855   "^DD",33.1 ,33.12,.01 ,1,1,0)
  8856   33.12^B
  8857   "^DD",33.1 ,33.12,.01 ,1,1,1)
  8858   S ^DGOTH(3 3.1,DA(1), 1,"B",$E(X ,1,30),DA) =""
  8859   "^DD",33.1 ,33.12,.01 ,1,1,2)
  8860   K ^DGOTH(3 3.1,DA(1), 1,"B",$E(X ,1,30),DA)
  8861   "^DD",33.1 ,33.12,.01 ,3)
  8862   Type a num ber betwee n 1 and 99 , 0 decima l digits.
  8863   "^DD",33.1 ,33.12,.01 ,21,0)
  8864   ^.001^1^1^ 3180425^^
  8865   "^DD",33.1 ,33.12,.01 ,21,1,0)
  8866   The number  of the 36 5 days per iod, for w hich the d ata was up dated.
  8867   "^DD",33.1 ,33.12,.01 ,"DT")
  8868   3180425
  8869   "^DD",33.1 ,33.12,.02 ,0)
  8870   90 DAYS PE RIOD^NJ1,0 ^^0;2^K:+X '=X!(X>2)! (X<1)!(X?. E1"."1N.N)  X
  8871   "^DD",33.1 ,33.12,.02 ,3)
  8872   Enter the  number of  the 90 day s period f or the upd ate.
  8873   "^DD",33.1 ,33.12,.02 ,21,0)
  8874   ^.001^1^1^ 3180425^^
  8875   "^DD",33.1 ,33.12,.02 ,21,1,0)
  8876   The number  of the 90  days peri od, for wh ich the da ta was upd ated.
  8877   "^DD",33.1 ,33.12,.02 ,"DT")
  8878   3180425
  8879   "^DD",33.1 ,33.12,.03 ,0)
  8880   FIELD UPDA TED^S^1:ST ART DATE;2 :AUTHORIZE D BY;3:AUT H. RECEIVE D DATE;4:O TH PATIENT  STATUS;5: VBA ADJUDI CATION STA TUS;6:VBA  ADJUDICATI ON DATE;7: AUTH. EFFE CTIVE DATE ;8:AUTH. C OMMENT;9:D ATE REQUES T SUBMITTE D;^0;3^Q
  8881   "^DD",33.1 ,33.12,.03 ,3)
  8882   Select the  field tha t was upda ted.
  8883   "^DD",33.1 ,33.12,.03 ,21,0)
  8884   ^.001^1^1^ 3180425^^
  8885   "^DD",33.1 ,33.12,.03 ,21,1,0)
  8886   The field  that was u pdated.
  8887   "^DD",33.1 ,33.12,.03 ,"DT")
  8888   3190315
  8889   "^DD",33.1 ,33.12,.04 ,0)
  8890   PREVIOUS V ALUE^FJ60^ ^0;4^K:$L( X)>60!($L( X)<1) X
  8891   "^DD",33.1 ,33.12,.04 ,3)
  8892   Answer mus t be 1-60  characters  in length .
  8893   "^DD",33.1 ,33.12,.04 ,21,0)
  8894   ^^1^1^3180 425^
  8895   "^DD",33.1 ,33.12,.04 ,21,1,0)
  8896   The previo us value.
  8897   "^DD",33.1 ,33.12,.04 ,23,0)
  8898   ^^1^1^3180 425^
  8899   "^DD",33.1 ,33.12,.04 ,23,1,0)
  8900   The previo us values  in free te xt format.
  8901   "^DD",33.1 ,33.12,.04 ,"DT")
  8902   3180425
  8903   "^DD",33.1 ,33.12,.05 ,0)
  8904   NEW VALUE^ FJ60^^0;5^ K:$L(X)>60 !($L(X)<1)  X
  8905   "^DD",33.1 ,33.12,.05 ,3)
  8906   Answer mus t be 1-60  characters  in length .
  8907   "^DD",33.1 ,33.12,.05 ,21,0)
  8908   ^^1^1^3180 425^
  8909   "^DD",33.1 ,33.12,.05 ,21,1,0)
  8910   The new va lue.
  8911   "^DD",33.1 ,33.12,.05 ,23,0)
  8912   ^^1^1^3180 425^
  8913   "^DD",33.1 ,33.12,.05 ,23,1,0)
  8914   The new va lue in the  free text  format.
  8915   "^DD",33.1 ,33.12,.05 ,"DT")
  8916   3180425
  8917   "^DD",33.1 ,33.12,.06 ,0)
  8918   EDITED BY  USER^P200' ^VA(200,^0 ;6^Q
  8919   "^DD",33.1 ,33.12,.06 ,3)
  8920   Select the  person wh o made the  changes.
  8921   "^DD",33.1 ,33.12,.06 ,21,0)
  8922   ^^1^1^3180 430^
  8923   "^DD",33.1 ,33.12,.06 ,21,1,0)
  8924   The person  who made  the change s.
  8925   "^DD",33.1 ,33.12,.06 ,"DT")
  8926   3180430
  8927   "^DD",33.1 ,33.12,.07 ,0)
  8928   EDITED DAT E/TIME^D^^ 0;7^S %DT= "EST" D ^% DT S X=Y K :X<1 X
  8929   "^DD",33.1 ,33.12,.07 ,3)
  8930   Enter the  date/time  when the c hanges wer e made.
  8931   "^DD",33.1 ,33.12,.07 ,21,0)
  8932   ^^1^1^3180 813^
  8933   "^DD",33.1 ,33.12,.07 ,21,1,0)
  8934   The date/t ime when t he changes  were made .
  8935   "^DD",33.1 ,33.12,.07 ,"DT")
  8936   3180813
  8937   "^DD",33.1 ,33.12,.08 ,0)
  8938   CHANGE REA SON^FJ60^^ 0;8^K:$L(X )>60!($L(X )<1) X
  8939   "^DD",33.1 ,33.12,.08 ,3)
  8940   Enter the  reason for  inactivat ion/reacti vation of  the OTH pa tient's co untdown cl ock. Answe r must be  1 to 60 ch aracters i n length.
  8941   "^DD",33.1 ,33.12,.08 ,21,0)
  8942   ^^2^2^3180 705^
  8943   "^DD",33.1 ,33.12,.08 ,21,1,0)
  8944   This field  capture t he reason  for reacti vation/ina ctivation  of the Oth er 
  8945   "^DD",33.1 ,33.12,.08 ,21,2,0)
  8946   Than Honor able patie nt countdo wn clock.
  8947   "^DD",33.1 ,33.12,.08 ,"DT")
  8948   3180905
  8949   "^DIC",33, 33,0)
  8950   OTH ELIGIB ILITY CLOC K^33
  8951   "^DIC",33, 33,0,"GL")
  8952   ^DGOTH(33,
  8953   "^DIC",33, 33,"%",0)
  8954   ^1.005^^0
  8955   "^DIC",33, 33,"%D",0)
  8956   ^1.001^3^3 ^3180207^^
  8957   "^DIC",33, 33,"%D",1, 0)
  8958   This file  contains d ata requir ed for tra cking the  status of  the 
  8959   "^DIC",33, 33,"%D",2, 0)
  8960   eligibilit y for emer gency Ment al Health  care for p atients wi th Other T han 
  8961   "^DIC",33, 33,"%D",3, 0)
  8962   Honorable  Discharge  type.
  8963   "^DIC",33, "B","OTH E LIGIBILITY  CLOCK",33 )
  8964  
  8965   "^DIC",33. 1,33.1,0)
  8966   OTH CLOCK  HISTORY^33 .1
  8967   "^DIC",33. 1,33.1,0," GL")
  8968   ^DGOTH(33. 1,
  8969   "^DIC",33. 1,33.1,"%" ,0)
  8970   ^1.005^^0
  8971   "^DIC",33. 1,33.1,"%D ",0)
  8972   ^^2^2^3180 425^
  8973   "^DIC",33. 1,33.1,"%D ",1,0)
  8974   The file k eeps the h istory of  who and wh en made ch anges to c ertain fie lds
  8975   "^DIC",33. 1,33.1,"%D ",2,0)
  8976   of the OTH  ELIGIBILI TY CLOCK F ILE (#33).
  8977   "^DIC",33. 1,"B","OTH  CLOCK HIS TORY",33.1 )
  8978  
  8979   **END**
  8980   **END**