KIDS Distribution saved on Feb 23, 2017@07:31:37 Add the ability to capture patient's preferred language **KIDS**:DG*5.3*887^SD*5.3*619^ **INSTALL NAME** DG*5.3*887 "BLD",9877,0) DG*5.3*887^REGISTRATION^0^3170223^y "BLD",9877,1,0) ^9.61A^2^2^3170222^^^^ "BLD",9877,1,1,0) This patch allows for the addition of language data to the Patient file. "BLD",9877,1,2,0) "BLD",9877,4,0) ^9.64PA^2^1 "BLD",9877,4,2,0) 2 "BLD",9877,4,2,2,0) ^9.641^2.07^1 "BLD",9877,4,2,2,2.07,0) LANGUAGE DATE/TIME (sub-file) "BLD",9877,4,2,2,2.07,1,0) ^9.6411^^ "BLD",9877,4,2,222) y^n^p^^^^n^^n "BLD",9877,4,2,224) "BLD",9877,4,"APDD",2,2.07) "BLD",9877,4,"B",2,2) "BLD",9877,6.3) 57 "BLD",9877,"ABPKG") n "BLD",9877,"KRN",0) ^9.67PA^779.2^20 "BLD",9877,"KRN",.4,0) .4 "BLD",9877,"KRN",.401,0) .401 "BLD",9877,"KRN",.402,0) .402 "BLD",9877,"KRN",.403,0) .403 "BLD",9877,"KRN",.5,0) .5 "BLD",9877,"KRN",.84,0) .84 "BLD",9877,"KRN",3.6,0) 3.6 "BLD",9877,"KRN",3.8,0) 3.8 "BLD",9877,"KRN",9.2,0) 9.2 "BLD",9877,"KRN",9.8,0) 9.8 "BLD",9877,"KRN",9.8,"NM",0) ^9.68A^9^8 "BLD",9877,"KRN",9.8,"NM",1,0) DGRPCADD^^0^B18204630 "BLD",9877,"KRN",9.8,"NM",2,0) DGRPV^^0^B19742844 "BLD",9877,"KRN",9.8,"NM",3,0) DGRPE^^0^B71849762 "BLD",9877,"KRN",9.8,"NM",4,0) DGRPD^^0^B69529511 "BLD",9877,"KRN",9.8,"NM",6,0) DGMUSTAT^^0^B7514407 "BLD",9877,"KRN",9.8,"NM",7,0) VADPT^^0^B16811812 "BLD",9877,"KRN",9.8,"NM",8,0) VADPT1^^0^B50294297 "BLD",9877,"KRN",9.8,"NM",9,0) VADPT0^^0^B13625852 "BLD",9877,"KRN",9.8,"NM","B","DGMUSTAT",6) "BLD",9877,"KRN",9.8,"NM","B","DGRPCADD",1) "BLD",9877,"KRN",9.8,"NM","B","DGRPD",4) "BLD",9877,"KRN",9.8,"NM","B","DGRPE",3) "BLD",9877,"KRN",9.8,"NM","B","DGRPV",2) "BLD",9877,"KRN",9.8,"NM","B","VADPT",7) "BLD",9877,"KRN",9.8,"NM","B","VADPT0",9) "BLD",9877,"KRN",9.8,"NM","B","VADPT1",8) "BLD",9877,"KRN",19,0) 19 "BLD",9877,"KRN",19,"NM",0) ^9.68A^2^2 "BLD",9877,"KRN",19,"NM",1,0) DG MANAGER MENU^^2 "BLD",9877,"KRN",19,"NM",2,0) DG MEANINGFUL USE LANG STATS^^0 "BLD",9877,"KRN",19,"NM","B","DG MANAGER MENU",1) "BLD",9877,"KRN",19,"NM","B","DG MEANINGFUL USE LANG STATS",2) "BLD",9877,"KRN",19.1,0) 19.1 "BLD",9877,"KRN",101,0) 101 "BLD",9877,"KRN",409.61,0) 409.61 "BLD",9877,"KRN",771,0) 771 "BLD",9877,"KRN",779.2,0) 779.2 "BLD",9877,"KRN",870,0) 870 "BLD",9877,"KRN",8989.51,0) 8989.51 "BLD",9877,"KRN",8989.52,0) 8989.52 "BLD",9877,"KRN",8994,0) 8994 "BLD",9877,"KRN","B",.4,.4) "BLD",9877,"KRN","B",.401,.401) "BLD",9877,"KRN","B",.402,.402) "BLD",9877,"KRN","B",.403,.403) "BLD",9877,"KRN","B",.5,.5) "BLD",9877,"KRN","B",.84,.84) "BLD",9877,"KRN","B",3.6,3.6) "BLD",9877,"KRN","B",3.8,3.8) "BLD",9877,"KRN","B",9.2,9.2) "BLD",9877,"KRN","B",9.8,9.8) "BLD",9877,"KRN","B",19,19) "BLD",9877,"KRN","B",19.1,19.1) "BLD",9877,"KRN","B",101,101) "BLD",9877,"KRN","B",409.61,409.61) "BLD",9877,"KRN","B",771,771) "BLD",9877,"KRN","B",779.2,779.2) "BLD",9877,"KRN","B",870,870) "BLD",9877,"KRN","B",8989.51,8989.51) "BLD",9877,"KRN","B",8989.52,8989.52) "BLD",9877,"KRN","B",8994,8994) "BLD",9877,"QDEF") ^^^^NO^^^^NO^^NO "BLD",9877,"QUES",0) ^9.62^^ "BLD",9877,"REQB",0) ^9.611^4^3 "BLD",9877,"REQB",2,0) DG*5.3*871^1 "BLD",9877,"REQB",3,0) DG*5.3*754^1 "BLD",9877,"REQB",4,0) VA FILEMAN 22.2^1 "BLD",9877,"REQB","B","DG*5.3*754",3) "BLD",9877,"REQB","B","DG*5.3*871",2) "BLD",9877,"REQB","B","VA FILEMAN 22.2",4) "FIA",2) PATIENT "FIA",2,0) ^DPT( "FIA",2,0,0) 2I "FIA",2,0,1) y^n^p^^^^n^^n "FIA",2,0,10) "FIA",2,0,11) "FIA",2,0,"RLRO") "FIA",2,0,"VR") 5.3^DG "FIA",2,2) 1 "FIA",2,2,7) "FIA",2,2.07) 0 "KRN",19,383,-1) 2^1 "KRN",19,383,0) DG MANAGER MENU^ADT Manager Menu^^M^.5^^^^^^^114^^1^1 "KRN",19,383,10,0) ^19.01PI^22^22 "KRN",19,383,10,22,0) 14527 "KRN",19,383,10,22,"^") DG MEANINGFUL USE LANG STATS "KRN",19,383,"U") ADT MANAGER MENU "KRN",19,14527,-1) 0^2 "KRN",19,14527,0) DG MEANINGFUL USE LANG STATS^Meaningful Use Language Statistics^^R^^^^^^^^REGISTRATION "KRN",19,14527,1,0) ^19.06^1^1^3160418^^ "KRN",19,14527,1,1,0) This option gives Meaningful Use Language statistics. "KRN",19,14527,25) DGMUSTAT "KRN",19,14527,"U") MEANINGFUL USE LANGUAGE STATIS "MBREQ") 0 "ORD",18,19) 19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA "ORD",18,19,0) OPTION "PKG",114,-1) 1^1 "PKG",114,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",114,22,0) ^9.49I^1^1 "PKG",114,22,1,0) 5.3^2930813^2930821 "PKG",114,22,1,"PAH",1,0) 887^3170223^53 "PKG",114,22,1,"PAH",1,1,0) ^^2^2^3170223 "PKG",114,22,1,"PAH",1,1,1,0) This patch allows for the addition of language data to the Patient file. "PKG",114,22,1,"PAH",1,1,2,0) "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 8 "RTN","DGMUSTAT") 0^6^B7514407 "RTN","DGMUSTAT",1,0) DGMUSTAT ;KNR/WCS - PREFERRED LANGUAGE RECORD FOR ACTIVE PATIENTS ; July 16, 2014 "RTN","DGMUSTAT",2,0) ;;5.3;Registration;**887**;Aug 13, 1993;Build 57 "RTN","DGMUSTAT",3,0) ; "RTN","DGMUSTAT",4,0) EN ;*///* "RTN","DGMUSTAT",5,0) D HOME^%ZIS "RTN","DGMUSTAT",6,0) W @IOF,"Preferred Language Record for Active Patients",!!! "RTN","DGMUSTAT",7,0) W "This program will calculate the number of patients who have designated",! "RTN","DGMUSTAT",8,0) W "a preferred language in their record at this facility.",!! "RTN","DGMUSTAT",9,0) S %ZIS="AEQ" D ^%ZIS G:POP EXIT "RTN","DGMUSTAT",10,0) I $D(IO("Q")) DO G EXIT "RTN","DGMUSTAT",11,0) .S ZTIO=ION,ZTSAVE="",ZTRTN="GO^DGMUSTAT",ZTDESC="Meaningful Use Statistics" "RTN","DGMUSTAT",12,0) .D ^%ZTLOAD W:$D(ZTSK) !,"Queued as task: ",ZTSK,!! "RTN","DGMUSTAT",13,0) ; "RTN","DGMUSTAT",14,0) GO S DGPATCNT=0 K DGLANG "RTN","DGMUSTAT",15,0) S DGSSN="" F S DGSSN=$O(^DPT("SSN",DGSSN)) Q:DGSSN="" DO "RTN","DGMUSTAT",16,0) .F DFN=0:0 S DFN=$O(^DPT("SSN",DGSSN,DFN)) Q:DFN="" DO "RTN","DGMUSTAT",17,0) ..Q:$P($G(^DPT(DFN,.35)),U)]"" ; deceased patients "RTN","DGMUSTAT",18,0) ..S DGPATCNT=DGPATCNT+1 ; count total patients "RTN","DGMUSTAT",19,0) ..S DGDATE="9999999.9999",DGDATE=$O(^DPT(DFN,.207,"B",DGDATE),-1) Q:DGDATE="" "RTN","DGMUSTAT",20,0) ..S DA=$O(^DPT(DFN,.207,"B",DGDATE,0)) Q:DA="" "RTN","DGMUSTAT",21,0) ..S DGDATA=$G(^DPT(DFN,.207,DA,0)) Q:DGDATA="" "RTN","DGMUSTAT",22,0) ..S DGLANGNM=$P(DGDATA,U,2) ; Language name "RTN","DGMUSTAT",23,0) ..I DGLANGNM]"" S DGLANG(DGLANGNM)=$G(DGLANG(DGLANGNM))+1 ; count language names "RTN","DGMUSTAT",24,0) ; "RTN","DGMUSTAT",25,0) PRINT U IO S PG=0 "RTN","DGMUSTAT",26,0) S DGTOTPTL=0 S DGLANGNM="" F S DGLANGNM=$O(DGLANG(DGLANGNM)) Q:DGLANGNM="" S DGTOTPTL=DGTOTPTL+DGLANG(DGLANGNM) "RTN","DGMUSTAT",27,0) D HDR "RTN","DGMUSTAT",28,0) S DOTS="........................." "RTN","DGMUSTAT",29,0) W !! S DGLANGNM="",DGLANGCT=0 F S DGLANGNM=$O(DGLANG(DGLANGNM)) Q:DGLANGNM="" DO "RTN","DGMUSTAT",30,0) .W DGLANGNM," ",$E(DOTS,2,(25-$X)),?25,DGLANG(DGLANGNM),! S DGLANGCT=DGLANGCT+1 I $Y>(IOSL-7) D HDR "RTN","DGMUSTAT",31,0) W !! "RTN","DGMUSTAT",32,0) I DGLANGCT>0 S X=(DGTOTPTL/DGPATCNT)*100 "RTN","DGMUSTAT",33,0) I DGLANGCT=0 S X="0.00" "RTN","DGMUSTAT",34,0) W ?12,"Total Count of Patient Records: ",DGPATCNT,! "RTN","DGMUSTAT",35,0) W ?4,"Total Patients with preferred language: ",DGTOTPTL,!! "RTN","DGMUSTAT",36,0) W ?10,"Total unique preferred languages: ",DGLANGCT,! "RTN","DGMUSTAT",37,0) W " % Patient records with preferred language: ",$J(X,0,1)," %",! "RTN","DGMUSTAT",38,0) ; "RTN","DGMUSTAT",39,0) EXIT K %ZIS,DA,DFN,DGDATA,DGDATE,DGLANG,DGLANGCT,DGLANGNM,DGLANGPT,DGPATCNT,DGSSN,DGTOTPTL,DOTS,PG,X "RTN","DGMUSTAT",40,0) K ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK "RTN","DGMUSTAT",41,0) Q "RTN","DGMUSTAT",42,0) ; "RTN","DGMUSTAT",43,0) HDR S PG=PG+1 "RTN","DGMUSTAT",44,0) W @IOF,"Preferred Language Record for Active Patients",?(IOM-12),"Page: ",PG,!! "RTN","DGMUSTAT",45,0) W "Language",?25,"Count",! "RTN","DGMUSTAT",46,0) F X=1:1:IOM W "-" "RTN","DGMUSTAT",47,0) Q "RTN","DGRPCADD") 0^1^B18204630 "RTN","DGRPCADD",1,0) DGRPCADD ;ALB/MRL,BAJ,TDM - REGISTRATION SCREEN 1.1/CONFIDENTIAL ADDRESS INFORMATION ; July 09, 2014 "RTN","DGRPCADD",2,0) ;;5.3;Registration;**489,624,688,754,887**;Aug 13, 1993;Build 57 "RTN","DGRPCADD",3,0) ;;**688 BAJ Jan 17,2006 Modifications to support Foreign addresses "RTN","DGRPCADD",4,0) CADD ;Confidential Address "RTN","DGRPCADD",5,0) N CNT,DGA1,DGA2,DGA3,DGA4,DGACT,DGBEG,DGCAN,DGCAT,DGCC,DGEND,DGTYP,DGTYPNAM,DGX,DGXX,DGZ,DGZIP,DGI,Y,Z,DGERR "RTN","DGRPCADD",6,0) N DGA14,DGA15,DGA16,FORGN,DGCNTRY,DGA1315 "RTN","DGRPCADD",7,0) S DGRPS=1.1 D H^DGRPU "RTN","DGRPCADD",8,0) S DGRP(.141)=$G(^DPT(DFN,.141)) "RTN","DGRPCADD",9,0) S Z=1,DGRPW=1.1 D WW^DGRPV W "Confidential Address" "RTN","DGRPCADD",10,0) ; if no data or no Category, display "NO CONFIDENTIAL..." "RTN","DGRPCADD",11,0) ;I DGRP(.141)=""!($P(DGRP(.141),U)="")!('$P($$CAACT(DFN),U)) D G END "RTN","DGRPCADD",12,0) I DGRP(.141)=""!('$P($$CAACT(DFN),U)) D G END "RTN","DGRPCADD",13,0) .W !?5,"NO CONFIDENTIAL ADDRESS" "RTN","DGRPCADD",14,0) .W !!?42,"From/To: NOT APPLICABLE" "RTN","DGRPCADD",15,0) S DGXX=DGRP(.141),DGA1=$P(DGXX,"^",1),DGA2=$P(DGXX,"^",2),DGA3=$P(DGXX,"^",3),DGA4=$P(DGXX,"^",4) "RTN","DGRPCADD",16,0) S DGA14=$P(DGXX,"^",14),DGA15=$P(DGXX,"^",15) "RTN","DGRPCADD",17,0) S DGA16=$P(DGXX,"^",16) S:'DGA16 DGA16="" "RTN","DGRPCADD",18,0) S DGCNTRY=$E($$CNTRYI^DGADDUTL(DGA16),1,25),FORGN=$$FORIEN^DGADDUTL(DGA16) "RTN","DGRPCADD",19,0) I DGCNTRY=-1 S DGCNTRY="UNKNOWN COUNTRY" "RTN","DGRPCADD",20,0) W:DGA1'="" !?3,DGA1 "RTN","DGRPCADD",21,0) I 'FORGN D "RTN","DGRPCADD",22,0) . ;If we didn't skip a line for Address Line 1, skip line now "RTN","DGRPCADD",23,0) . I DGA1="" W ! "RTN","DGRPCADD",24,0) . W ?43,"County: " "RTN","DGRPCADD",25,0) . I $D(^DIC(5,+$P(DGRP(.141),"^",5),1,+$P(DGRP(.141),"^",11),0)) D "RTN","DGRPCADD",26,0) . . S DGCC=^DIC(5,+$P(DGRP(.141),"^",5),1,+$P(DGRP(.141),"^",11),0) W $P(DGCC,"^",1),"(",$P(DGCC,"^",3),")" "RTN","DGRPCADD",27,0) S DGA1315=$P($G(^DPT(DFN,.13)),U,15) S:DGA1315="" DGA1315="UNANSWERED" "RTN","DGRPCADD",28,0) I DGA2'="" W !?3,DGA2,?44,"Phone: ",DGA1315 "RTN","DGRPCADD",29,0) I DGA3'="" W !?3,DGA3 I DGA2="" W ?44,"Phone: ",DGA1315 "RTN","DGRPCADD",30,0) I FORGN W !?3,DGA15_" "_DGA4_" "_DGA14 "RTN","DGRPCADD",31,0) I 'FORGN W !?3,DGA4 D "RTN","DGRPCADD",32,0) . I $D(^DIC(5,+$P(DGRP(.141),"^",5),0)) W ",",$P(^DIC(5,+$P(DGRP(.141),"^",5),0),"^",2) "RTN","DGRPCADD",33,0) . S DGZIP=$P(DGRP(.141),"^",6) I $L(DGZIP)>5 S DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,12) "RTN","DGRPCADD",34,0) . W " ",DGZIP "RTN","DGRPCADD",35,0) I DGA2="",DGA3="" W ?44,"Phone: ",DGA1315 "RTN","DGRPCADD",36,0) W !?3,DGCNTRY "RTN","DGRPCADD",37,0) W ?42,"From/To: " S (DGZ,DGX)="" F DGI=7,8 S DGZ=$P(DGRP(.141),"^",DGI),Y=DGZ D "RTN","DGRPCADD",38,0) .I DGI=7 X:Y]"" ^DD("DD") S DGBEG=Y,DGX=Y "RTN","DGRPCADD",39,0) .I DGI=8 X:Y]"" ^DD("DD") S DGEND=Y,DGX=DGX_"-"_$S(Y]"":Y,1:"UNANSWERED") "RTN","DGRPCADD",40,0) W DGX "RTN","DGRPCADD",41,0) W !!,"Categories: " I $D(^DPT(DFN,.14)) D "RTN","DGRPCADD",42,0) .S DGCAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR") "RTN","DGRPCADD",43,0) .S DGX="",DGCAN="" F S DGCAN=$O(^DPT(DFN,.14,DGCAN)) Q:DGCAN="" D "RTN","DGRPCADD",44,0) ..Q:'$D(^DPT(DFN,.14,DGCAN,0)) "RTN","DGRPCADD",45,0) ..S DGTYP=$P(^DPT(DFN,.14,DGCAN,0),"^",1),DGACT=$P(^DPT(DFN,.14,DGCAN,0),"^",2) "RTN","DGRPCADD",46,0) ..S DGACT=$S(DGACT="Y":"Active",DGACT="N":"Inactive",1:"Unanswered") "RTN","DGRPCADD",47,0) ..S DGTYPNAM="" F DGI=1:1 S DGTYPNAM=$P(DGCAT,";",DGI) Q:DGTYPNAM="" D "RTN","DGRPCADD",48,0) ...I DGTYPNAM[DGTYP S DGTYPNAM=$P(DGTYPNAM,":",2),DGX=DGTYPNAM_"("_DGACT_")"_","_DGX "RTN","DGRPCADD",49,0) S DGXX="",CNT=0 F DGI=1:1 S DGXX=$P(DGX,",",DGI) Q:DGXX="" D "RTN","DGRPCADD",50,0) .W:CNT>0 ! "RTN","DGRPCADD",51,0) .W ?13,DGXX "RTN","DGRPCADD",52,0) .S CNT=CNT+1 "RTN","DGRPCADD",53,0) ; line feed before continuing "RTN","DGRPCADD",54,0) W ! "RTN","DGRPCADD",55,0) END ; "RTN","DGRPCADD",56,0) S DGRP(.13)=$G(^DPT(DFN,.13)) "RTN","DGRPCADD",57,0) S Z=2,DGRPW=1.1 D WW^DGRPV W " Cell Phone: " "RTN","DGRPCADD",58,0) ; "RTN","DGRPCADD",59,0) ;* Output Cell phone "RTN","DGRPCADD",60,0) I $P(DGRP(.13),U,4)'="" W ?19,$P(DGRP(.13),U,4) "RTN","DGRPCADD",61,0) I $P(DGRP(.13),U,4)="" W ?19,"UNANSWERED" "RTN","DGRPCADD",62,0) ; "RTN","DGRPCADD",63,0) ;* Output Pager "RTN","DGRPCADD",64,0) W !," Pager #: " "RTN","DGRPCADD",65,0) I $P(DGRP(.13),U,5)'="" W ?19,$P(DGRP(.13),U,5) "RTN","DGRPCADD",66,0) I $P(DGRP(.13),U,5)="" W ?19,"UNANSWERED" "RTN","DGRPCADD",67,0) ; "RTN","DGRPCADD",68,0) ;* Output Email Address "RTN","DGRPCADD",69,0) W !," Email Address: " "RTN","DGRPCADD",70,0) I $P(DGRP(.13),U,3)'="" W ?19,$P(DGRP(.13),U,3) "RTN","DGRPCADD",71,0) I $P(DGRP(.13),U,3)="" W ?19,"UNANSWERED" "RTN","DGRPCADD",72,0) ; "RTN","DGRPCADD",73,0) LANGUAGE ;Get language data *///* "RTN","DGRPCADD",74,0) S DGLANGDT=9999999,(DGPRFLAN,DGLANG0,DGRP(1),DGRP(2))="" "RTN","DGRPCADD",75,0) S DGLANGDT=$O(^DPT(DFN,.207,"B",DGLANGDT),-1) "RTN","DGRPCADD",76,0) I DGLANGDT="" G L1 "RTN","DGRPCADD",77,0) S DGLANGDA=$O(^DPT(DFN,.207,"B",DGLANGDT,0)) I DGLANGDA="" S DGRP(2)="" G L1 "RTN","DGRPCADD",78,0) S DGLANG0=$G(^DPT(DFN,.207,DGLANGDA,0)),Y=$P(DGLANG0,U),DGPRFLAN=$P(DGLANG0,U,2) "RTN","DGRPCADD",79,0) S Y=DGLANGDT X ^DD("DD") S DGLANGDT=Y "RTN","DGRPCADD",80,0) S DGRP(1)=DGLANGDT,DGRP(2)=DGPRFLAN "RTN","DGRPCADD",81,0) K DGLANGDT,DGPRFLAN,DGLANG0,DGLANGDA "RTN","DGRPCADD",82,0) ; "RTN","DGRPCADD",83,0) L1 W !! S Z=3,DGRPW=1.1 D WW^DGRPV ;*///* "RTN","DGRPCADD",84,0) W ?4,"Language Date/Time: ",$S(DGRP(1)="":"UNANSWERED",1:DGRP(1)) "RTN","DGRPCADD",85,0) W !?5,"Preferred Language: ",$S(DGRP(2)="":"UNANSWERED",1:DGRP(2)) "RTN","DGRPCADD",86,0) ; "RTN","DGRPCADD",87,0) G ^DGRPP "RTN","DGRPCADD",88,0) CAACT(DFN,ACTDT) ;Determines if the Confidential Address is active "RTN","DGRPCADD",89,0) ;Input: DFN - Patient (#2) file internal entry number (Required) "RTN","DGRPCADD",90,0) ; ACTDT - Date used to determine if address is active "RTN","DGRPCADD",91,0) ; (Optional) Defaults to DT if not defined. "RTN","DGRPCADD",92,0) ; "RTN","DGRPCADD",93,0) ;Output: "RTN","DGRPCADD",94,0) ; 1st piece 0 inactive based on start/stop dates "RTN","DGRPCADD",95,0) ; 1 active based on start/stop dates "RTN","DGRPCADD",96,0) ; 2nd piece 0 - no active correspondence types "RTN","DGRPCADD",97,0) ; 1 - at least one active correspondence type "RTN","DGRPCADD",98,0) ; "RTN","DGRPCADD",99,0) N DGCA,DGCABEG,DGCAEND,DGSTAT,DGIEN,DGTYP,DGFLG "RTN","DGRPCADD",100,0) S DGSTAT="0^0" "RTN","DGRPCADD",101,0) I '$D(DFN) Q DGSTAT "RTN","DGRPCADD",102,0) I '$D(ACTDT) S ACTDT=DT "RTN","DGRPCADD",103,0) S DGCA=$G(^DPT(DFN,.141)) D "RTN","DGRPCADD",104,0) .I DGCA="" Q "RTN","DGRPCADD",105,0) .S DGCABEG=$P(DGCA,U,7) "RTN","DGRPCADD",106,0) .S DGCAEND=$P(DGCA,U,8) "RTN","DGRPCADD",107,0) .I 'DGCABEG!(DGCABEG>ACTDT)!(DGCAEND&(DGCAEND0 S DFN=+Y N Y W ! S DIR(0)="E" D ^DIR G SEL:$D(DTOUT)!($D(DUOUT)) D EN G SEL "RTN","DGRPD",12,0) EN ;call to display patient inquiry - input DFN "RTN","DGRPD",13,0) ;MPI/PD CHANGE "RTN","DGRPD",14,0) S DGCMOR="UNSPECIFIED",DGMPI=$G(^DPT(+DFN,"MPI")) "RTN","DGRPD",15,0) S DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$P(DGMPI,U,3)),DGLOCATN=$S(+DGLOCATN>0:$P($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED") "RTN","DGRPD",16,0) I $D(DGMPI),$D(DGLOCATN) S DGCMOR=$P(DGLOCATN,"^") "RTN","DGRPD",17,0) ;END MPI/PD CHANGE "RTN","DGRPD",18,0) K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0),"^",38),1:0),DGRPU="UNSPECIFIED" D DEM^VADPT,HDR^DGRPD1 F I=0,.11,.13,.121,.122,.31,.32,.36,.361,.141,.3 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRPD",19,0) S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU S DGTMPAD=0 I $P(DGRP(.121),"^",9)="Y" S DGTMPAD=$S('$P(DGRP(.121),"^",8):1,$P(DGRP(.121),"^",8)'50) !?9 W:'(I#2) ?48 W DGA(I) "RTN","DGRPD",22,0) S DGCC=+$P(DGRP(.11),U,7),DGST=+$P(DGRP(.11),U,5),DGCC=$S($D(^DIC(5,DGST,1,DGCC,0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) "RTN","DGRPD",23,0) N DGCNTRY,DGFORGN S DGCNTRY=$P(DGRP(.11),"^",10),DGFORGN=$$FORIEN^DGADDUTL(DGCNTRY) I 'DGFORGN W !?2,"County: ",DGCC "RTN","DGRPD",24,0) S X="NOT APPLICABLE" I DGTMPAD S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU) "RTN","DGRPD",25,0) N DGSKIP S DGSKIP=$S(DGFORGN:"!,?42,""From/To: """,1:"?42, ""From/To: """) "RTN","DGRPD",26,0) W @DGSKIP,X,!?3,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S('DGTMPAD:X,$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU) K DGTMPADW "RTN","DGRPD",27,0) W !?2,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU) "RTN","DGRPD",28,0) W !?4,"Cell: ",$S($P(DGRP(.13),U,4)]"":$P(DGRP(.13),U,4),1:DGRPU) "RTN","DGRPD",29,0) W !?2,"E-mail: ",$S($P(DGRP(.13),U,3)]"":$P(DGRP(.13),U,3),1:DGRPU) "RTN","DGRPD",30,0) W !,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$$BADADR^DGUTL3(+DFN)) "RTN","DGRPD",31,0) D CA "RTN","DGRPD",32,0) N DGEMER S DGEMER=$$EXTERNAL^DILFD(2,.181,"",$P($G(^DPT(DFN,.18)),"^")) "RTN","DGRPD",33,0) W:DGEMER]"" !?32,"Emergency Response: ",DGEMER "RTN","DGRPD",34,0) I 'DGABBRV 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:"UNSPECIFIED") "RTN","DGRPD",35,0) I 'DGABBRV W !?2,"Relig: ",$S($D(^DIC(13,+$P(DGRP(0),"^",8),0)):$P(^(0),"^",1),1:DGRPU),?46,"Sex: ",$S($P(VADM(5),"^",2)]"":$P(VADM(5),"^",2),1:"UNSPECIFIED") "RTN","DGRPD",36,0) I 'DGABBRV W ! D "RTN","DGRPD",37,0) .N RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF "RTN","DGRPD",38,0) .K ^UTILITY($J,"W") "RTN","DGRPD",39,0) .S PTR=0 F S PTR=+$O(^DPT(DFN,.02,PTR)) Q:'PTR D "RTN","DGRPD",40,0) ..S VAL=+$G(^DPT(DFN,.02,PTR,0)) "RTN","DGRPD",41,0) ..Q:$$INACTIVE^DGUTL4(VAL,1) "RTN","DGRPD",42,0) ..S VAL=$$PTR2TEXT^DGUTL4(VAL,1) S:+$O(^DPT(DFN,.02,PTR)) VAL=VAL_", " "RTN","DGRPD",43,0) ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP "RTN","DGRPD",44,0) .M RACE=^UTILITY($J,"W",0) S:$G(RACE(1,0))="" RACE(1,0)="UNANSWERED" "RTN","DGRPD",45,0) .K ^UTILITY($J,"W") "RTN","DGRPD",46,0) .S PTR=0 F S PTR=+$O(^DPT(DFN,.06,PTR)) Q:'PTR D "RTN","DGRPD",47,0) ..S VAL=+$G(^DPT(DFN,.06,PTR,0)) "RTN","DGRPD",48,0) ..Q:$$INACTIVE^DGUTL4(VAL,2) "RTN","DGRPD",49,0) ..S VAL=$$PTR2TEXT^DGUTL4(VAL,2) S:+$O(^DPT(DFN,.06,PTR)) VAL=VAL_", " "RTN","DGRPD",50,0) ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP "RTN","DGRPD",51,0) .M ETHNIC=^UTILITY($J,"W",0) S:$G(ETHNIC(1,0))="" ETHNIC(1,0)="UNANSWERED" "RTN","DGRPD",52,0) .K ^UTILITY($J,"W") "RTN","DGRPD",53,0) .W ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0) "RTN","DGRPD",54,0) .F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0)) W !,?9,$G(RACE(X,0)),?51,$G(ETHNIC(X,0)) "RTN","DGRPD",55,0) I '$$OKLINE^DGRPD1(16) G Q "RTN","DGRPD",56,0) D LANGUAGE "RTN","DGRPD",57,0) I '$$OKLINE^DGRPD1(10) G Q "RTN","DGRPD",58,0) ;display cv status #4156 "RTN","DGRPD",59,0) N DGCV S DGCV=$$CVEDT^DGCV(+DFN) "RTN","DGRPD",60,0) W !!,?2,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",$P(DGCV,U,3)="":"NOT ELIGIBLE",1:"EXPIRED") I DGCV>0 W ?45,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ") "RTN","DGRPD",61,0) ;display primary eligibility "RTN","DGRPD",62,0) S X1=DGRP(.36),X=$P(DGRP(.361),"^",1) W !,"Primary Eligibility: ",$S($D(^DIC(8,+X1,0)):$P(^(0),"^",1)_" ("_$S(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU) "RTN","DGRPD",63,0) W !,"Other Eligibilities: " 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 "RTN","DGRPD",64,0) I '$$OKLINE^DGRPD1(16) G Q "RTN","DGRPD",65,0) ;employability status "RTN","DGRPD",66,0) W !?6,"Unemployable: ",$S($P(DGRP(.3),U,5)="Y":"YES",1:"NO") "RTN","DGRPD",67,0) I '$$OKLINE^DGRPD1(19) G Q "RTN","DGRPD",68,0) ;display the catastrophic disability review date if there is one "RTN","DGRPD",69,0) D CATDIS^DGRPD1 "RTN","DGRPD",70,0) I $G(DGPRFLG)=1 G Q:'$$OKLINE^DGRPD1(19) D "RTN","DGRPD",71,0) . N DGPDT,DGPTM "RTN","DGRPD",72,0) . W !,$$REPEAT^XLFSTR("-",78) "RTN","DGRPD",73,0) . S DGPDT="",DGPDT=$O(^DGS(41.41,"ADC",DFN,DGPDT),-1) "RTN","DGRPD",74,0) . W !,"[PRE-REGISTER DATE:] "_$S(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE") "RTN","DGRPD",75,0) . S DGPTM=$$PCTEAM^DGSDUTL(DFN) "RTN","DGRPD",76,0) . I $P(DGPTM,U,2)]"" W !,"[PRIMARY CARE TEAM:] "_$P(DGPTM,U,2) "RTN","DGRPD",77,0) . W !,$$REPEAT^XLFSTR("-",78) "RTN","DGRPD",78,0) ; Check if patient is an inpatient and on a DOM ward "RTN","DGRPD",79,0) ; If inpatient is on a DOM ward, don't display MT or CP messages "RTN","DGRPD",80,0) ; If inpatient is NOT on a DOM ward, don't display CP message "RTN","DGRPD",81,0) N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR "RTN","DGRPD",82,0) G Q:'$$OKLINE^DGRPD1(16) "RTN","DGRPD",83,0) D DOM^DGMTR "RTN","DGRPD",84,0) I '$G(DGDOM) D "RTN","DGRPD",85,0) .D DIS^DGMTU(DFN) "RTN","DGRPD",86,0) .D IN5^VADPT "RTN","DGRPD",87,0) .I $G(VAIP(1))="" D DISP^IBARXEU(DFN,DT,3,1) "RTN","DGRPD",88,0) ;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W ! "RTN","DGRPD",89,0) D DIS^EASECU(DFN) ;Added for LTC III (DG*5.3*518) "RTN","DGRPD",90,0) S VAIP("L")="" "RTN","DGRPD",91,0) I $$OKLINE^DGRPD1(14) D INP "RTN","DGRPD",92,0) I '$G(DGRPOUT),($$OKLINE^DGRPD1(10)) D SA ;*KNR* "RTN","DGRPD",93,0) ;MPI/PD CHANGE "RTN","DGRPD",94,0) Q D KVA^VADPT K %DT,D0,D1,DGA,DGA1,DGA2,DGABBRV,DGAD,DGCC,DGCMOR,DGDOM,DGLOCATN,DGMPI,DGRP,DGRPU,DGS,DGST,DGXFR0,DIC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,I,I1,L,LDM,POP,SDCT,VA,X,X1,Y Q "RTN","DGRPD",95,0) CA ;Confidential Address "RTN","DGRPD",96,0) W !!?1,"Confidential Address: ",?44,"Confidential Address Categories:" "RTN","DGRPD",97,0) N DGCABEG,DGCAEND,DGA,DGARRAY,DGERROR "RTN","DGRPD",98,0) S DGCABEG=$P(DGRP(.141),U,7),DGCAEND=$P(DGRP(.141),U,8) "RTN","DGRPD",99,0) I 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND43) !?9 W:'(I#2) ?44 W DGA(I) "RTN","DGRPD",115,0) W !?1,"From/To: ",$$FMTE^XLFDT(DGCABEG)_"-"_$S(DGCAEND'="":$$FMTE^XLFDT(DGCAEND),1:"UNANSWERED") "RTN","DGRPD",116,0) Q "RTN","DGRPD",117,0) INP S VAIP("D")="L" D INP^DGPMV10 "RTN","DGRPD",118,0) S DGPMT=0 "RTN","DGRPD",119,0) D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q "RTN","DGRPD",120,0) SA F I=0:0 S I=$O(^DGS(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:$$OKLINE^DGRPD1(17) SAA Q:$G(DGRPOUT) "RTN","DGRPD",121,0) Q "RTN","DGRPD",122,0) SAA ;Scheduled Admit Data "RTN","DGRPD",123,0) W !!?14,"Scheduled Admit" "RTN","DGRPD",124,0) W:$D(^DIC(42,+$P(X,U,8),0)) " on ward "_$P(^(0),U) "RTN","DGRPD",125,0) W:$D(^DIC(45.7,+$P(X,U,9),0)) " for treating specialty "_$P(^(0),U) "RTN","DGRPD",126,0) W " on "_$$FMTE^XLFDT(L,"5DZ") "RTN","DGRPD",127,0) Q ;SAA "RTN","DGRPD",128,0) ; "RTN","DGRPD",129,0) 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=SDCT+1 W:SDCT=1 !!,"Currently enrolled in " W:$X>50 !?22 W $S($D(^SC(+^(0),0)):$P(^(0),"^",1)_", ",1:"") "RTN","DGRPD",130,0) ; "RTN","DGRPD",131,0) FA ; "RTN","DGRPD",132,0) N DGARRAY,SDCNT "RTN","DGRPD",133,0) S DGARRAY("FLDS")="1;2;3;18",DGARRAY(4)=DFN,DGARRAY(1)=DT,DGARRAY("SORT")="P" "RTN","DGRPD",134,0) S SDCNT=$$SDAPI^SDAMA301(.DGARRAY),CT=0 W !!,"Future Appointments: " "RTN","DGRPD",135,0) ;if there is lower subscripts hanging from the 101 node, "RTN","DGRPD",136,0) ;then it is a valid appointment, otherwise it is "RTN","DGRPD",137,0) ;an error eg 01/20/2005 "RTN","DGRPD",138,0) ;G:'$$OKLINE^DGRPD1(13) RMK ;*///* "RTN","DGRPD",139,0) I $D(^TMP($J,"SDAMA301",101))=1 W "Appointment Database is Unavailable" G RMK "RTN","DGRPD",140,0) I $O(^TMP($J,"SDAMA301",DFN,DT))'>0 W "NONE" G RMK "RTN","DGRPD",141,0) ; "RTN","DGRPD",142,0) W ?22,"Date",?33,"Time",?39,"Clinic",!?22 F I=22:1:75 W "=" "RTN","DGRPD",143,0) F FA=DT:0 S FA=$O(^TMP($J,"SDAMA301",DFN,FA)) G RMK:'FA D Q:CT>5 "RTN","DGRPD",144,0) .N STAT S STAT=$P($P(^TMP($J,"SDAMA301",DFN,FA),U,3),";") "RTN","DGRPD",145,0) .S C=+$P(^TMP($J,"SDAMA301",DFN,FA),U,2) I STAT'["C" D "RTN","DGRPD",146,0) ..D COV "RTN","DGRPD",147,0) ..N DGAPPT S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z") "RTN","DGRPD",148,0) ..W !?22,$P(DGAPPT,"@"),?33,$P(DGAPPT,"@",2) "RTN","DGRPD",149,0) ..W ?39,$P($P(^TMP($J,"SDAMA301",DFN,FA),U,2),";",2)," ",COV "RTN","DGRPD",150,0) ..Q "RTN","DGRPD",151,0) I $O(^TMP($J,"SDAMA301",DFN,FA))>0 W !,"See Scheduling options for additional appointments." "RTN","DGRPD",152,0) RMK I '$G(DGRPOUT),($$OKLINE^DGRPD1(15)) W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10) ;*///* "RTN","DGRPD",153,0) D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO") "RTN","DGRPD",154,0) W !! "RTN","DGRPD",155,0) W "Date of Death Information" "RTN","DGRPD",156,0) W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E")) "RTN","DGRPD",157,0) W !,?5,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E")) "RTN","DGRPD",158,0) W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E")) "RTN","DGRPD",159,0) W !,?5,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),! "RTN","DGRPD",160,0) I $$OKLINE^DGRPD1(14) D EC^DGRPD1 "RTN","DGRPD",161,0) K DGARRAY,SDCNT,^TMP($J,"SDAMA301"),ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y killed after dghinqky "RTN","DGRPD",162,0) Q "RTN","DGRPD",163,0) COV S COV=$S(+$P(^TMP($J,"SDAMA301",DFN,FA),U,18)=7:" (Collateral) ",1:"") "RTN","DGRPD",164,0) S COV=COV_$S(STAT["NT":" * NO ACTION TAKEN *",STAT["N":" * NO-SHOW *",1:""),CT=CT+1 Q "RTN","DGRPD",165,0) Q "RTN","DGRPD",166,0) ; "RTN","DGRPD",167,0) OREN S XQORQUIT=1 Q:'$D(ORVP) S DFN=+ORVP D EN R !!,"Press RETURN to CONTINUE: ",X:DTIME "RTN","DGRPD",168,0) Q "RTN","DGRPD",169,0) LANGUAGE ; Get language data *///* "RTN","DGRPD",170,0) S DGLANGDT=9999999,(DGPRFLAN,DGLANG0)="" "RTN","DGRPD",171,0) S DGLANGDT=$O(^DPT(DFN,.207,"B",DGLANGDT),-1) "RTN","DGRPD",172,0) I DGLANGDT="" G L1 "RTN","DGRPD",173,0) S DGLANGDA=$O(^DPT(DFN,.207,"B",DGLANGDT,0)) "RTN","DGRPD",174,0) S DGLANG0=$G(^DPT(DFN,.207,DGLANGDA,0)),Y=$P(DGLANG0,U),DGPRFLAN=$P(DGLANG0,U,2) "RTN","DGRPD",175,0) S Y=DGLANGDT X ^DD("DD") S DGLANGDT=Y "RTN","DGRPD",176,0) L1 W !!,"Language Date/Time: ",$S(DGLANGDT="":"UNANSWERED",1:DGLANGDT),! "RTN","DGRPD",177,0) W ?1,"Preferred Language: ",$S(DGPRFLAN="":"UNANSWERED",1:DGPRFLAN) "RTN","DGRPD",178,0) K DGLANGDT,DGPRFLAN,DGLANG0,DGLANGDA "RTN","DGRPD",179,0) Q "RTN","DGRPE") 0^3^B71849762 "RTN","DGRPE",1,0) DGRPE ;ALB/MRL,LBD,BRM,TMK,BAJ,PWC - REGISTRATIONS EDITS ; 02 May 2016 3:20 PM "RTN","DGRPE",2,0) ;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415,489,506,244,547,522,528,555,508,451,626,638,624,677,672,702,689,735,688,797,842,865,871,887**;Aug 13, 1993;Build 57 "RTN","DGRPE",3,0) ; "RTN","DGRPE",4,0) ;DGDR contains a string of edits; edit=screen*10+item # "RTN","DGRPE",5,0) ; "RTN","DGRPE",6,0) ;line tag screen*10+item*1000 = continuation line "RTN","DGRPE",7,0) ; "RTN","DGRPE",8,0) I DGRPS=1,DGDR["101," D CEDITS^DGRPECE(DFN) "RTN","DGRPE",9,0) I DGRPS=8 D ^DGRPEIS,Q Q ; family demographic edit...not conventional!! :) "RTN","DGRPE",10,0) I DGRPS=9 D EDIT9^DGRPEIS2,Q Q ; income screening data ($$$) "RTN","DGRPE",11,0) I DGRPS=5,DGDR["501," D "RTN","DGRPE",12,0) .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q "RTN","DGRPE",13,0) .D REG^IBCNBME(DFN) "RTN","DGRPE",14,0) .Q "RTN","DGRPE",15,0) N QUIT S QUIT=0 "RTN","DGRPE",16,0) I DGRPS=6,$S(DGDR["601,"!(DGDR["602,")!(DGDR["603,"):1,1:0) D I QUIT D Q Q ;Screen 6 subscreens "RTN","DGRPE",17,0) .;Use new ListMan screen for Military Service Episodes (DG*5.3*797) "RTN","DGRPE",18,0) . I DGDR["601," D EN^DGRP61(DFN) ; MSEs "RTN","DGRPE",19,0) . ; D SETDR("601,",.DR) "RTN","DGRPE",20,0) . ; S (DA,Y)=DFN,DIE="^DPT(" "RTN","DGRPE",21,0) . ; D ^DIE I $D(Y) S QUIT=1 "RTN","DGRPE",22,0) . ; S DGDR=$P(DGDR,"601,",1)_$P(DGDR,"601,",2,999) "RTN","DGRPE",23,0) . I DGDR["602," D EN^DGRP6CL(DFN,.QUIT) Q:QUIT ; Conflicts "RTN","DGRPE",24,0) . I DGDR["603," D EN^DGRP6EF(DFN,.QUIT) Q:QUIT ; Exposures "RTN","DGRPE",25,0) I DGRPS=7,(DGDR["702,") D EN^DGRP7CP(DFN,.QUIT) I QUIT D Q Q ;DG*5.3*842 screen 7 cp subscreen "RTN","DGRPE",26,0) I DGRPS=11,(DGDR["1105,") D EN^DGR111(DFN) ;DG*5.3*871 screen 11 HBP subscreen "RTN","DGRPE",27,0) ;-- Tricare screen #15 "RTN","DGRPE",28,0) I DGRPS=15 D EDIT^DGRP15,Q Q "RTN","DGRPE",29,0) ; "RTN","DGRPE",30,0) N DGPH,DGPHFLG "RTN","DGRPE",31,0) K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0 "RTN","DGRPE",32,0) G ^DGRPE1:DGRPS>6 "RTN","DGRPE",33,0) I DGRPS=4 D ^DGRPE4 "RTN","DGRPE",34,0) D SETDR(DGDR,.DR) "RTN","DGRPE",35,0) S (DA,Y)=DFN,DIE="^DPT(" "RTN","DGRPE",36,0) D ^DIE "RTN","DGRPE",37,0) ;check for Combat Vet status "RTN","DGRPE",38,0) I $G(DGCVFLG)=1,($P($$CVEDT^DGCV(DFN),U,2)']"") D "RTN","DGRPE",39,0) . W !!,"**NOTE-Change(s) made in this session deleted the veteran's Combat Vet status!" "RTN","DGRPE",40,0) . S DIR(0)="EA" D ^DIR K DIR "RTN","DGRPE",41,0) I $G(DGPHFLG)>0 D EDITPH1^DGRPLE() "RTN","DGRPE",42,0) Q K DA,DIE,DR,DGCT,DGCVFLG,DGDR,DGDRD,DGDRS,DGRPADI,I,J,J1,DGCOMLOC,DIPA "RTN","DGRPE",43,0) Q "RTN","DGRPE",44,0) ; "RTN","DGRPE",45,0) SETDR(DGDR,DR) ; Set up DR string(s) for edit groups selected "RTN","DGRPE",46,0) N DGCT,DGDRS,J1,J2 "RTN","DGRPE",47,0) K DR S DR="",DGDRS="DR",DGCT=0 "RTN","DGRPE",48,0) F I=1:1 S J=$P(DGDR,",",I) Q:J="" S J1=J D:$T(@J1) "RTN","DGRPE",49,0) . S DGDRD=$P($T(@J1),";;",2) D S "RTN","DGRPE",50,0) . N J2 "RTN","DGRPE",51,0) . F J2=0:1 S J1=J*1000+J2 Q:'$T(@J1) S DGDRD=$P($T(@J1),";;",2) D S "RTN","DGRPE",52,0) Q "RTN","DGRPE",53,0) ; "RTN","DGRPE",54,0) S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q "RTN","DGRPE",55,0) S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q "RTN","DGRPE",56,0) Q "RTN","DGRPE",57,0) ; "RTN","DGRPE",58,0) SETFLDS(DGDR) ; Set up fields to edit "RTN","DGRPE",59,0) Q "RTN","DGRPE",60,0) ; "RTN","DGRPE",61,0) ;- added line 113 for screen 1.1, item 3 "RTN","DGRPE",62,0) 101 ;; "RTN","DGRPE",63,0) 102 ;;1; "RTN","DGRPE",64,0) 103 ;;.091; "RTN","DGRPE",65,0) 104 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG); "RTN","DGRPE",66,0) 105 ;;.12105//NO;S:X="N" Y="@15" S:X="Y" DIE("NO^")="";.1217;I X']"" W !?4,$C(7),"But I need a Start Date for this Temporary Address." S Y=.12105;.1218; "RTN","DGRPE",67,0) 105000 ;;N RET S RET=1 D EN^DGREGTED(DFN,"TEMP",.RET) S:'RET Y=.12105;@15;K DIE("NO^"); "RTN","DGRPE",68,0) 109 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);.02;D DR207^DGRPE;7LANGUAGE DATE/TIME;D LANGDEL^DGRPE;D DR109^DGRPE;6;2;K DR(2,2.02),DR(2,2.06);.05;.08;K DIE("NO^"); "RTN","DGRPE",69,0) 111 ;;.14105//NO;S:X="N" Y="@111" S:X="Y" DIE("NO^")="";.1417;I X']"" W !?4,$C(7),"But I need a Start Date." S Y=.14105;.1418;D DR111^DGRPE;.141;I '$P($$CAACT^DGRPCADD(DFN),U,2) W !?4,"But I need at least one active category." S Y=.14105; "RTN","DGRPE",70,0) 111000 ;;K DR(2,2.141);N RET S RET=1 D EN^DGREGTED(DFN,"CONF",.RET) S:'RET Y=.14105;@111;K DIE("NO^"); "RTN","DGRPE",71,0) 112 ;;.134;.135;@21;S X=$$YN1316^DGRPE(DFN);S:(X["N")&($P($G(^DPT(DFN,.13)),"^",3)="") Y="@25";S:(X["N")&($P($G(^DPT(DFN,.13)),"^",3)]"") Y="@24";.133;S:($P($G(^DPT(DFN,.13)),U,16)="Y")&($G(X)="") Y="@21";S Y="@25";@24;.133///@;@25;.1317///NOW; "RTN","DGRPE",72,0) 113 ;;D DR207^DGRPE;7LANGUAGE DATE/TIME;D LANGDEL^DGRPE "RTN","DGRPE",73,0) 201 ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE; "RTN","DGRPE",74,0) 202 ;;1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^"); "RTN","DGRPE",75,0) 203 ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06); "RTN","DGRPE",76,0) 205 ;;.181; "RTN","DGRPE",77,0) 301 ;;.211;S:X']"" Y="@31";.212;D DR301^DGRPE S:DG4=1 Y=.213;.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y=.21011;.213;K DG4;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215:.217;.2207;.219;.21011;@31; "RTN","DGRPE",78,0) 302 ;;.2191;S:X']"" Y="@32";.2192;D DR301^DGRPE S:DG4=1 Y=.2193;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y=.211011; "RTN","DGRPE",79,0) 302000 ;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;.2199;.211011;@32; "RTN","DGRPE",80,0) 303 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@33";.3305//NO;I X="Y" S Y="@34",DGX1=1 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7);@33;.331;S:X']"" DGX1=2,Y="@34";.332;@34; "RTN","DGRPE",81,0) 303000 ;;S:$G(DGX1) Y="@341";.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335:.337;.2201;.339;.33011;S DGX1=2;@341; "RTN","DGRPE",82,0) 303001 ;;S:$G(DGX1)=2 Y="@35";S DGX2=$G(^DPT(DA,.21));.331///^S X=$P(DGX2,U);.332///^S X=$P(DGX2,U,2);.333////^S X=$P(DGX2,U,3);.334///^S X=$P(DGX2,U,4);@35; "RTN","DGRPE",83,0) 303002 ;;S:$G(DGX1)=2 Y="@351";.335///^S X=$P(DGX2,U,5);.336///^S X=$P(DGX2,U,6);.337///^S X=$P(DGX2,U,7);.338///^S X=$P(DGX2,U,8);.339///^S X=$P(DGX2,U,9);.33011///^S X=$P(DGX2,U,11);@351;K DGX1,DGX2; "RTN","DGRPE",84,0) 304 ;;.3311;S:X']"" Y="@36";.3312;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315:.3317;.2204;.3319;.331011;@36; "RTN","DGRPE",85,0) 305 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@37";.3405//NO;I X="Y" S DGX1=1,Y="@371" S:$D(^DPT(DFN,.22)) $P(^(.22),U,2)=$P(^(.22),U,7);@37;.341;S:X']"" DGX1=2,Y="@371";.342;@371; "RTN","DGRPE",86,0) 305000 ;;S:$G(DGX1) Y="@38";.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345:.347;.2202;.349;.34011;S DGX1=2;@38; "RTN","DGRPE",87,0) 305001 ;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341///^S X=$P(DGX2,U);.342///^S X=$P(DGX2,U,2);.343///^S X=$P(DGX2,U,3);.344///^S X=$P(DGX2,U,4);@381 "RTN","DGRPE",88,0) 305002 ;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346///^S X=$P(DGX2,U,6);.347///^S X=$P(DGX2,U,7);.348///^S X=$P(DGX2,U,8);.349///^S X=$P(DGX2,U,9);.34011///^S X=$P(DGX2,U,11);@39;K DGX1,DGX2; "RTN","DGRPE",89,0) 401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41; "RTN","DGRPE",90,0) 402 ;;.2514;.2515;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@42" S:(X'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42; "RTN","DGRPE",91,0) 501 ;; "RTN","DGRPE",92,0) 502 ;;.381;.382///NOW; "RTN","DGRPE",93,0) 503 ;;.383; "RTN","DGRPE",94,0) 601 ;;Q; "RTN","DGRPE",95,0) 602 ;;Q; "RTN","DGRPE",96,0) 603 ;;Q; "RTN","DGRPE",97,0) 604 ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62; "RTN","DGRPE",98,0) 605 ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63; "RTN","DGRPE",99,0) 606 ;;I $P($G(^DPT(DFN,.361)),U,3)="H" S Y="@6131";.3602//NO;.3603//NO;S Y="@6132";@6131;.3602;.3603;@6132; "RTN","DGRPE",100,0) 607 ;;.368//NO;.369//NO;I $S('$D(^DPT(DA,.36)):1,$P(^(.36),U,8)="Y"!($P(^(.36),U,9)="Y"):0,1:1) S Y="@614";.37;@614; "RTN","DGRPE",101,0) 608 ;;S DGPHFLG=0;.531;S:X'="Y" DGX=X,Y="@616";.532///^S X="PENDING";S Y="@6161";@616;S:DGX'="N" Y="@6162";.533///^S X="VAMC";@6161;S DGPHFLG=1;.535///^S X=$$DIV^DGRPLE();@6162; "RTN","DGRPE",102,0) AD N DGZ4,DGPC "RTN","DGRPE",103,0) S X=$S($D(^DPT(DA,.11)):^(.11),1:""),DGZ4=$P(X,U,12),DGPHONE=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(DGADD)):^(DGADD),1:""),^(DGADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_DGPHONE_U_$P(Y,U,10) "RTN","DGRPE",104,0) I DGZ4 S DGPC=$S((DGADD=.33):1,(DGADD=.34):2,(DGADD=.211):3,(DGADD=.331):4,(DGADD=.311):5,(DGADD=.25):6,(DGADD=.21):7,1:0) S:DGPC $P(^DPT(DFN,.22),U,DGPC)=DGZ4 "RTN","DGRPE",105,0) K DGADD,DGPHONE Q "RTN","DGRPE",106,0) DR109 ;Drop through (use same logic as DR203) "RTN","DGRPE",107,0) DR203 S DR(2,2.02)=".01RACE;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.02,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2031"";.02;@2031;" "RTN","DGRPE",108,0) S DR(2,2.06)=".01ETHNICITY;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.06,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2032"";.02;@2032;" "RTN","DGRPE",109,0) Q "RTN","DGRPE",110,0) DR111 ; Set DR string for Confidential Address categories "RTN","DGRPE",111,0) S DR(2,2.141)=".01;1//YES;" "RTN","DGRPE",112,0) Q "RTN","DGRPE",113,0) DR207 ; DR string for preferred language ;*///* "RTN","DGRPE",114,0) S DR(2,2.07)=".01;.02//ENGLISH;D LANGDEL^DGRPE" "RTN","DGRPE",115,0) Q "RTN","DGRPE",116,0) DR301 ; set up variables for foreign address "RTN","DGRPE",117,0) N DG3,DG33 "RTN","DGRPE",118,0) S DG4=0 "RTN","DGRPE",119,0) S DG3=$P($G(^DPT(DFN,.11)),U,10) "RTN","DGRPE",120,0) S DG33=$O(^HL(779.004,"B","USA","")) "RTN","DGRPE",121,0) I $G(DG3)]"",(DG3'=$G(DG33)) S DG4=1 "RTN","DGRPE",122,0) Q "RTN","DGRPE",123,0) PRF ; Write Proof needed for FV "RTN","DGRPE",124,0) W !?4,$C(7),"Proof is required for Filipino vet." "RTN","DGRPE",125,0) Q "RTN","DGRPE",126,0) ; "RTN","DGRPE",127,0) SET32(DA,DIPA,SEQ) ; Extract the .32 node from patient file and set DIPA "RTN","DGRPE",128,0) ; array with the BOS and component data for the SEQ military service "RTN","DGRPE",129,0) ; episode (1-3) "RTN","DGRPE",130,0) N I,Q,Z "RTN","DGRPE",131,0) K DIPA(32,SEQ) "RTN","DGRPE",132,0) S Q=$G(^DPT(DA,.32)),Z=$G(^(.3291)) "RTN","DGRPE",133,0) S DIPA(32,SEQ)=$P(Q,U,SEQ*5)_U_$P(Z,U,SEQ),DIPA("X"_SEQ)=$P(DIPA(32,SEQ),U) "RTN","DGRPE",134,0) Q "RTN","DGRPE",135,0) ; "RTN","DGRPE",136,0) WARN32(X,DIPA,SEQ,Y) ; Warn if the BOS is changed, then the component will "RTN","DGRPE",137,0) ; be deleted "RTN","DGRPE",138,0) ; Returns Y to skip component if the component should not be asked "RTN","DGRPE",139,0) ; for this branch of service "RTN","DGRPE",140,0) N Z "RTN","DGRPE",141,0) I '$$CMP(X) S Y="@601"_SEQ "RTN","DGRPE",142,0) S Z=$G(DIPA(32,SEQ)) "RTN","DGRPE",143,0) Q:$S($P(Z,U,2)=""!($P(Z,U)=""):1,1:$P(Z,U)=X) "RTN","DGRPE",144,0) ; "RTN","DGRPE",145,0) I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",! "RTN","DGRPE",146,0) Q "RTN","DGRPE",147,0) ; "RTN","DGRPE",148,0) CMP(X) ; Function to determine if service component is valid for "RTN","DGRPE",149,0) ; branch of service ien in X 0 = invalid 1 = valid "RTN","DGRPE",150,0) ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS "RTN","DGRPE",151,0) Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0) "RTN","DGRPE",152,0) ; "RTN","DGRPE",153,0) YN1316(DFN) ;Email address indicator - DG*5.3*865 "RTN","DGRPE",154,0) N %,RSLT "RTN","DGRPE",155,0) S DIE("NO^")="" "RTN","DGRPE",156,0) P1316 ; "RTN","DGRPE",157,0) S %=0 "RTN","DGRPE",158,0) W !,"DOES THE PATIENT HAVE AN EMAIL ADDRESS? Y/N" "RTN","DGRPE",159,0) D YN^DICN "RTN","DGRPE",160,0) I %=0 W !," If the patient has a valid Email Address, please answer with 'Yes'.",!," If no Email Address please answer with 'No'." G P1316 "RTN","DGRPE",161,0) I %=-1 W !," EXIT NOT ALLOWED ??" G P1316 "RTN","DGRPE",162,0) S RSLT=$S(%=1:"Y",%=2:"N") "RTN","DGRPE",163,0) N FDA,IENS "RTN","DGRPE",164,0) Q:'$G(DFN) "RTN","DGRPE",165,0) S IENS=DFN_",",FDA(2,IENS,.1316)=RSLT "RTN","DGRPE",166,0) D FILE^DIE("","FDA") "RTN","DGRPE",167,0) Q RSLT "RTN","DGRPE",168,0) ; "RTN","DGRPE",169,0) INPXF207 ; Input transform for field 7 in file ;*///* "RTN","DGRPE",170,0) I $L(X)>60!($L(X)<1) K X Q "RTN","DGRPE",171,0) I X="*" S X="DECLINED TO ANSWER",FMT="?($X+3)" D EN^DDIOL(X,"",FMT) Q "RTN","DGRPE",172,0) I $D(X) DO "RTN","DGRPE",173,0) .N DIC S DIC(0)="EQMN",DIC="^DI(.85,",DIC("S")="S DIC(""W"")="""" I $P(^DI(.85,+Y,0),U,7)=""L"",$P(^(0),U,2)]""""" "RTN","DGRPE",174,0) .D ^DIC S:+Y>0 X=$P(^DI(.85,+Y,0),U) I +Y<0 K X "RTN","DGRPE",175,0) Q "RTN","DGRPE",176,0) ; "RTN","DGRPE",177,0) XHELP207 ; This is a screen to be sure the language is a 'living' language, i.e.in use today and that it has the required 2-character code. ;*///* "RTN","DGRPE",178,0) N X S X="?" N DIC S DIC("S")="S DIC(""W"")="""" I $P(^DI(.85,+Y,0),U,7)=""L"",$P(^(0),U,2)]""""" S DIC(0)="EQM",DIC="^DI(.85," D ^DIC "RTN","DGRPE",179,0) Q "RTN","DGRPE",180,0) ; "RTN","DGRPE",181,0) LANGDEL ; If no language entered, remove the stub record ;*///* "RTN","DGRPE",182,0) Q:'$G(D1) "RTN","DGRPE",183,0) N X S X=$G(^DPT(DFN,.207,D1,0)) Q:X="" "RTN","DGRPE",184,0) I $P(X,U,2)="" DO "RTN","DGRPE",185,0) .W $C(7),!!,"No language was entered. Record deleted!",! H 3 "RTN","DGRPE",186,0) .S DIK="^DPT(DFN,.207,",DA=D1 D ^DIK K DIK "RTN","DGRPE",187,0) Q "RTN","DGRPV") 0^2^B19742844 "RTN","DGRPV",1,0) DGRPV ;ALB/MRL,RTK,PJR,BRM,TMK,AMA,LBD,TDM,PWC - REGISTRATION DEFINE VARIABLES ON ENTRY ;July 09, 2014 "RTN","DGRPV",2,0) ;;5.3;Registration;**109,114,247,190,327,365,343,397,415,489,546,545,451,624,677,672,689,716,688,797,842,871,887**;Aug 13, 1993;Build 57 "RTN","DGRPV",3,0) ; "RTN","DGRPV",4,0) ; "RTN","DGRPV",5,0) ;set up variables for registration screen processing "RTN","DGRPV",6,0) ; "RTN","DGRPV",7,0) ;DGRPVV :string of 15 ones and zeros each character corresponding to "RTN","DGRPV",8,0) ; a particular screen (0 means allow edit, 1 means don't) "RTN","DGRPV",9,0) ; "RTN","DGRPV",10,0) ;DGRPVV(n):where n=screen number. String of x ones and zeros where "RTN","DGRPV",11,0) ; x is the number of elements on screen n (0=edit, 1=don't) "RTN","DGRPV",12,0) ; "RTN","DGRPV",13,0) ;DGVI :Turn on high intensity "RTN","DGRPV",14,0) ;DGVO :Turn off high intensity "RTN","DGRPV",15,0) ; "RTN","DGRPV",16,0) EN D DT^DICRW I '$D(DVBGUI) D HOME^%ZIS "RTN","DGRPV",17,0) S (DGVI,DGVO)="""""" I $S('$D(IOST(0)):1,'$D(^DG(43,1,0)):1,'$P(^DG(43,1,0),"^",36):1,$D(^DG(43,1,"TERM",IOST(0))):1,1:0) G M ;goto M if not high intensity "RTN","DGRPV",18,0) I $D(^%ZIS(2,IOST(0),7)) S I=^(7),X=$S($P(I,"^",3)]"":3,1:2) I $L($P(I,"^",1)),$L($P(I,"^",X)) S DGVI=$P(I,"^",1),DGVO=$P(I,"^",X) "RTN","DGRPV",19,0) M I $L(DGVI_DGVO)>4 S X=132 X ^%ZOSF("RM") "RTN","DGRPV",20,0) S DGRPW=1,DGRPCM=0,DGRPU="UNANSWERED",DGRPNA="NOT APPLICABLE",DGRPV=$S($D(DGRPV):DGRPV,1:1) "RTN","DGRPV",21,0) MSE ;Move MSE data from node .32 to .3216 multiple in Patient file #2 "RTN","DGRPV",22,0) ;DG*5.3*797 "RTN","DGRPV",23,0) I '$D(^DPT(DFN,.3216)) D MOVMSE^DGMSEUTL(DFN) "RTN","DGRPV",24,0) SC7 S X=$S('$D(^DPT(DFN,"TYPE")):0,1:+^("TYPE")) S:'$D(DGELVER) DGELVER=0 "RTN","DGRPV",25,0) S DGRPTYPE=$S($D(^DG(391,+X,0)):^(0),1:""),(DGRPSC,DGRPSCE,DGRPSCE1)="" S:'$D(DGELVER) DGELVER=0 "RTN","DGRPV",26,0) I DGRPTYPE'="" S DGRPSC=$G(^DG(391,+X,"S")),DGRPSCE=$G(^("E")),DGRPSCE1=$G(^("E10")) "RTN","DGRPV",27,0) ; "RTN","DGRPV",28,0) S DGPH=$P($G(^DPT(DFN,.53)),U) ;Purple Heart Indicator "RTN","DGRPV",29,0) I $G(DGPRFLG)=1 D "RTN","DGRPV",30,0) . S DGRPVV="000001111111111" "RTN","DGRPV",31,0) E D "RTN","DGRPV",32,0) . S DGRPVV="000000000000000" "RTN","DGRPV",33,0) S X="5^3^5^2^3^10^4^2^3^2^5^5^5^2^1" "RTN","DGRPV",34,0) F I=1:1:15 S J=+$P(X,"^",I),DGRPVV(I)=$S((I<12)!(I=15):$E("00000000000000000",1,J),1:$E("11111111111111111",1,J)) "RTN","DGRPV",35,0) S DGRPVV(1.1)="000" ; Add third 0 for Language ;*///* "RTN","DGRPV",36,0) S DGRPVV(2)="00010" "RTN","DGRPV",37,0) I $P($G(^DPT(DFN,.52)),U,9)'="" S $E(DGRPVV(6),4)=1 ;POW status verified, no editing (DG*5.3*688) "RTN","DGRPV",38,0) I $G(DGPH)]"" S $E(DGRPVV(6),8)=1 "RTN","DGRPV",39,0) S $E(DGRPVV(6),9,10)="11" "RTN","DGRPV",40,0) ; "RTN","DGRPV",41,0) F I=3,6,8,9,10,11 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99) "RTN","DGRPV",42,0) ; "RTN","DGRPV",43,0) ;-- if patient type is TRICARE then turn off screens 2,4 "RTN","DGRPV",44,0) ; "RTN","DGRPV",45,0) ;-- modified 08/20/2003 for NOIS Calls MAC-0400-61574 & AMA-0700-71769 "RTN","DGRPV",46,0) ;-- commented the line to allow screens 2 & 4 to display for Tricare "RTN","DGRPV",47,0) ;I DGRPTYPE["TRICARE" F I=2,4 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99) "RTN","DGRPV",48,0) ; "RTN","DGRPV",49,0) F I=31:0 S I=$O(^DD(391,I)) Q:I=""!(I>99) I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE,"^",I) S X1=$E(I),X2=$E(I,2) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99) "RTN","DGRPV",50,0) I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) S DGRPVV=$E(DGRPVV,0,7)_11_$E(DGRPVV,10,99) "RTN","DGRPV",51,0) K DIRUT,DUOUT,DTOUT "RTN","DGRPV",52,0) ; "RTN","DGRPV",53,0) ;Fields are numbered screen_item and put in that piece position. "RTN","DGRPV",54,0) ;Because FM does not allow more than 100 pieces on a node, it was "RTN","DGRPV",55,0) ;necessary to start a new node E10 for fields on screens 10 or higher. "RTN","DGRPV",56,0) ;In these instances, the piece position will be screen_item-100 so, "RTN","DGRPV",57,0) ;for example, screen 11, item 2 would be field 112, but piece 12. "RTN","DGRPV",58,0) ;Items on screens <10 will be found on node E. "RTN","DGRPV",59,0) ; "RTN","DGRPV",60,0) F I=100:0 S I=$O(^DD(391,I)) Q:I=""!(I>150) I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE1,"^",I-100) S X1=$E(I,1,2),X2=$E(I,3) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99) "RTN","DGRPV",61,0) ; "RTN","DGRPV",62,0) I $S('($D(DUZ)#2):0,'$D(^XUSEC("DG ELIGIBILITY",DUZ)):0,1:1) G ELVER ;if user holds eligibility key, skip "RTN","DGRPV",63,0) F I=.3,.32,.361 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRPV",64,0) S DGRPVV(10)=11 I $P(DGRP(.361),"^",1)="V" S DGRPVV(7)=111,DGRPVV(1)=1_$E(DGRPVV(1),2,99) ;if elig verified, can't edit elig data, name, ssn, or dob "RTN","DGRPV",65,0) I $P(DGRP(.3),"^",6)]"" S DGRPVV(8)=11 ;if monetary ben. verified, can't edit income screening data "RTN","DGRPV",66,0) I $P(DGRP(.32),"^",2)]"" S DGRPVV(6)=111111111 ;if service data verified, can't edit service screen "RTN","DGRPV",67,0) S DGRPVV(11)=$E(DGRPVV(11),1,4)_"0" ; turn on HBP to get to next screen where edit on/off will be controlled "RTN","DGRPV",68,0) ; "RTN","DGRPV",69,0) ELVER ;set up variables for eligibility verification "RTN","DGRPV",70,0) ;if elig ver option, only edit screens 1, 2, and 7 (and 6, 8, 9, 10, "RTN","DGRPV",71,0) ; and 11 if they're turned on). "RTN","DGRPV",72,0) ; "RTN","DGRPV",73,0) S DGRP(.361)=$G(^DPT(DFN,.361)) "RTN","DGRPV",74,0) I $P(DGRP(.361),U,3)="H" S DGRPVV(10)=10 "RTN","DGRPV",75,0) I $P($G(DGRP(.361)),U)="V",($P(DGRP(.361),U,3)="H") S DGRPVV(6)=$E(DGRPVV(6),1,5)_1_$E(DGRPVV(6),7,99),DGRPVV(11)=10000 "RTN","DGRPV",76,0) S:'DGELVER DGRPLAST=$S($G(DGPRFLG)=1:5,1:15) "RTN","DGRPV",77,0) I DGELVER S DGRPVV="00111"_$E(DGRPVV,6,11)_"1111" F I=1:1:11 S J=$E(DGRPVV,I) I 'J S DGRPLAST=I "RTN","DGRPV",78,0) Q K DGRPSC,DGRPSCE "RTN","DGRPV",79,0) Q "RTN","DGRPV",80,0) ; "RTN","DGRPV",81,0) WW ;Write number on screens for display and/or edit (Z=number) "RTN","DGRPV",82,0) W:DGRPW ! S Z=$S(DGRPCM:Z,DGRPV:"<"_Z_">",$E(DGRPVV(DGRPS),Z):"<"_Z_">",1:"["_Z_"]") "RTN","DGRPV",83,0) I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO "RTN","DGRPV",84,0) I 'DGRPCM&($E(Z)'="[") W Z "RTN","DGRPV",85,0) Q "RTN","DGRPV",86,0) ; "RTN","DGRPV",87,0) WW1 ;spacing for screen display (Z=item to print) "RTN","DGRPV",88,0) F Z2=1:1:(Z1-$L(Z)) S Z=Z_" " "RTN","DGRPV",89,0) W Z K Z2 "RTN","DGRPV",90,0) Q "RTN","DGRPV",91,0) ; "RTN","DGRPV",92,0) WW2 ; Write number on screen for fields always selectable "RTN","DGRPV",93,0) W:DGRPW ! S Z="["_Z_"]" "RTN","DGRPV",94,0) I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO "RTN","DGRPV",95,0) Q "RTN","VADPT") 0^7^B16811812 "RTN","VADPT",1,0) VADPT ;ALB/MRL/MJK,ERC,TDM - RETURN PATIENT VARIABLE ARRAYS [DRIVER] ; 7/17/14 "RTN","VADPT",2,0) ;;5.3;Registration;**193,343,389,415,489,498,688,754,887**;Aug 13, 1993;Build 57 "RTN","VADPT",3,0) ;DFN = Patient IFN [if not passed entire array returned as null] "RTN","VADPT",4,0) ; "RTN","VADPT",5,0) DEM ;Demographic Variables "RTN","VADPT",6,0) S VAN=1,VAN(1)=13,VAV="VADM" D ^VADPT0 Q ;/**/ "RTN","VADPT",7,0) ; "RTN","VADPT",8,0) OPD ;Other Patient Data "RTN","VADPT",9,0) S VAN=2,VAN(1)=8,VAV="VAPD" D ^VADPT0 Q "RTN","VADPT",10,0) ; "RTN","VADPT",11,0) ADD ;Current Address "RTN","VADPT",12,0) S VAN=3,VAN(1)=29,VAV="VAPA" D ^VADPT0 Q "RTN","VADPT",13,0) ; "RTN","VADPT",14,0) OAD ;Other Patient Variables "RTN","VADPT",15,0) S VAN=4,VAN(1)=11,VAV="VAOA" D ^VADPT0 Q "RTN","VADPT",16,0) ; "RTN","VADPT",17,0) INP ;Inpatient Data [pre-version 5] "RTN","VADPT",18,0) N VAINDTT S VAN=5,VAN(1)=11,VAV="VAIN",VAINDTT=$G(VAINDT) N VAINDT S:VAINDTT VAINDT=$$DATIM(VAINDTT) D ^VADPT0 Q "RTN","VADPT",19,0) ; "RTN","VADPT",20,0) IN5 ;Inpatient Data [v5.0 and above] "RTN","VADPT",21,0) N VAINDTT S VAN=6,VAN(1)=19,VAV=$S('$D(VAIP("V")):"VAIP",VAIP("V")'?1A.E:"VAIP",1:VAIP("V")),VAINDTT=$G(VAIP("D")) S:$L(VAINDTT) VAIP("D")=VAINDTT S:VAINDTT VAIP("D")=$$DATIM(VAINDTT) D ^VADPT0 S:$L(VAINDTT) VAIP("D")=VAINDTT Q "RTN","VADPT",22,0) ; "RTN","VADPT",23,0) ELIG ;Eligibility Information "RTN","VADPT",24,0) S VAN=7,VAN(1)=9,VAV="VAEL" D ^VADPT0 Q "RTN","VADPT",25,0) ; "RTN","VADPT",26,0) MB ;Monetary Benefits "RTN","VADPT",27,0) S VAN=8,VAN(1)=9,VAV="VAMB" D ^VADPT0 Q "RTN","VADPT",28,0) ; "RTN","VADPT",29,0) SVC ;Service Information "RTN","VADPT",30,0) S VAN=9,VAN(1)=14,VAV="VASV" D ^VADPT0 Q "RTN","VADPT",31,0) ; "RTN","VADPT",32,0) REG ;Registration data "RTN","VADPT",33,0) S VAN=10,VAV="VARP" D ^VADPT0 Q "RTN","VADPT",34,0) ; "RTN","VADPT",35,0) SDE ;Enrollment Information "RTN","VADPT",36,0) S VAN=11,VAV="VAEN" D ^VADPT0 Q "RTN","VADPT",37,0) ; "RTN","VADPT",38,0) SDA ;Appointment Information "RTN","VADPT",39,0) S VAN=12,VAV="VASD" D ^VADPT0 Q "RTN","VADPT",40,0) ; "RTN","VADPT",41,0) PID ;Patient Id "RTN","VADPT",42,0) S VAN=13,VAV="VA" D ^VADPT0 Q "RTN","VADPT",43,0) ; "RTN","VADPT",44,0) TESTPAT(DFN) ;Test patient ? Returns 0 (No) or 1 (Yes) "RTN","VADPT",45,0) S DFN=+$G(DFN) I 'DFN Q 0 "RTN","VADPT",46,0) I $D(^DPT("ATEST",DFN)) Q 1 "RTN","VADPT",47,0) N NODE S NODE=$G(^DPT(DFN,0)) "RTN","VADPT",48,0) I $P(NODE,"^",21)=1 Q 1 "RTN","VADPT",49,0) I $E($P(NODE,"^",9),1,5)="00000" Q 1 "RTN","VADPT",50,0) Q 0 "RTN","VADPT",51,0) ; "RTN","VADPT",52,0) V5 S X=$S($D(^DG(43,1,"VERSION")):+^("VERSION"),1:""),VADPT("V")=$S(X<5:0,1:1) K X Q "RTN","VADPT",53,0) OERR ; "RTN","VADPT",54,0) 1 S VATAG=1 D MULT Q "RTN","VADPT",55,0) 2 S VATAG=2 D MULT Q "RTN","VADPT",56,0) 3 S VATAG=3 D MULT Q "RTN","VADPT",57,0) 4 S VATAG=4 D MULT Q "RTN","VADPT",58,0) 5 S VATAG=5 D MULT Q "RTN","VADPT",59,0) 6 S VATAG=6 D MULT Q "RTN","VADPT",60,0) 7 S VATAG=7 D MULT Q "RTN","VADPT",61,0) 8 S VATAG=8 D MULT Q "RTN","VADPT",62,0) 9 S VATAG=9 D MULT Q "RTN","VADPT",63,0) 10 S VATAG=10 D MULT Q "RTN","VADPT",64,0) 51 S VATAG=11 D MULT Q "RTN","VADPT",65,0) 52 S VATAG=12 D MULT Q "RTN","VADPT",66,0) 53 S VATAG=13 D MULT Q "RTN","VADPT",67,0) ALL S VATAG=14 D MULT Q "RTN","VADPT",68,0) A5 S VATAG=15 D MULT Q "RTN","VADPT",69,0) SEL Q:$O(VARRAY(0))']"" S VATAG=0,VATAG(2)=$P($T(TAG),";;",2) "RTN","VADPT",70,0) F VATAG(1)=0:0 S VATAG=$O(VARRAY(VATAG)) Q:VATAG="" I VATAG(2)[("^"_VATAG_"^") S VARRAY(VATAG)=1,VAROOT=$S($D(VAROOT(VATAG)):VAROOT(VATAG),1:"") D @VATAG "RTN","VADPT",71,0) G Q "RTN","VADPT",72,0) ; "RTN","VADPT",73,0) MULT S VATAG=$P($T(TG+VATAG),";;",2) "RTN","VADPT",74,0) F VATAG(1)=1:1 S VATAG(2)=$P(VATAG,"^",VATAG(1)) Q:VATAG(2)="" S VAROOT=$S($D(VAROOT(VATAG(2))):VAROOT(VATAG(2)),1:"") D @(VATAG(2)) "RTN","VADPT",75,0) Q S VAROOT="" K:$D(VAROOT)'=11 VAROOT K VATAG Q "RTN","VADPT",76,0) ; "RTN","VADPT",77,0) KVA K VA "RTN","VADPT",78,0) KVAR D KVAR^VADPT0 K:$D(VAIP("V")) @(VAIP("V")) K I,X,Y,VARRAY,VADM,VAPD,VADPT,VAOA,VASV,VAEL,VAMB,VARP,VAEN,VASD,VAIN,VAIP,VAPA,VAHOW,VAINDT,VAERR,^UTILITY("VADPT",$J),VA200,VATEST Q "RTN","VADPT",79,0) DATIM(DATIM) ;If time not specified see if movement on that date "RTN","VADPT",80,0) Q:DATIM'?7N DATIM "RTN","VADPT",81,0) N A,B S A=$O(^DGPM("ADFN"_DFN,DATIM)),B=+$O(^(+A,0)) "RTN","VADPT",82,0) I 'A Q DATIM "RTN","VADPT",83,0) I $P($G(^DGPM(+B,0)),"^",2)=3 Q DATIM ;Next movement is discharge "RTN","VADPT",84,0) F Q:"^4^5^7^"'[(U_$P($G(^DGPM(+B,0)),"^",2)) S A=$O(^DGPM("ADFN"_DFN,A)),B=+$O(^(+A,0)) I $E(A,1,7)'=DATIM Q "RTN","VADPT",85,0) I 'A Q DATIM "RTN","VADPT",86,0) I $E(A,1,7)'=DATIM Q DATIM "RTN","VADPT",87,0) Q A "RTN","VADPT",88,0) ; "RTN","VADPT",89,0) TG ; "RTN","VADPT",90,0) ;;DEM^INP "RTN","VADPT",91,0) ;;DEM^ELIG "RTN","VADPT",92,0) ;;ELIG^INP "RTN","VADPT",93,0) ;;DEM^ADD "RTN","VADPT",94,0) ;;ADD^INP "RTN","VADPT",95,0) ;;DEM^ELIG^ADD "RTN","VADPT",96,0) ;;ELIG^SVC "RTN","VADPT",97,0) ;;ELIG^SVC^MB "RTN","VADPT",98,0) ;;DEM^REG^SDE^SDA "RTN","VADPT",99,0) ;;SDE^SDA "RTN","VADPT",100,0) ;;DEM^IN5 "RTN","VADPT",101,0) ;;ELIG^IN5 "RTN","VADPT",102,0) ;;ADD^IN5 "RTN","VADPT",103,0) ;;DEM^OPD^INP^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA "RTN","VADPT",104,0) ;;DEM^OPD^IN5^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA "RTN","VADPT",105,0) ; "RTN","VADPT",106,0) TAG ;;^DEM^OPD^INP^IN5^ADD^OAD^ELIG^SVC^MB^REG^SDE^SDA^ "RTN","VADPT0") 0^9^B13625852 "RTN","VADPT0",1,0) VADPT0 ;ALB/MRL/MJK,ERC,TDM - PATIENT VARIABLE ROUTINE DRIVER, CONT. ; 02/22/2016 "RTN","VADPT0",2,0) ;;5.3;Registration;**343,342,415,489,498,528,689,789,688,759,754,887**;Aug 13, 1993;Build 57 "RTN","VADPT0",3,0) ; "RTN","VADPT0",4,0) ;Initialize variables "RTN","VADPT0",5,0) N I1 "RTN","VADPT0",6,0) S U="^" D DT^DICRW:'$D(DT) "RTN","VADPT0",7,0) S VAERR=$S($G(DFN)="":1,'$D(^DPT(DFN,0)):1,1:0) "RTN","VADPT0",8,0) S Y=VAN'=13 I Y,$D(VAROOT)'[0,VAROOT]"" S Y=0,VAV=VAROOT K @VAV "RTN","VADPT0",9,0) I Y S:$S(VAN>9:1,'$D(VAHOW):0,1:VAHOW[2) VAV="^UTILITY("_""""_VAV_""""_","_$J_")" "RTN","VADPT0",10,0) D @VAN "RTN","VADPT0",11,0) Q K X,Y,VAC,VAS,VAV,VAW,VAN,I,VAX,VAZ Q "RTN","VADPT0",12,0) ; "RTN","VADPT0",13,0) INIT ; -- determine #'s or names then init array "RTN","VADPT0",14,0) ; "RTN","VADPT0",15,0) S VAS="1^2^3^4^5^6^7^8^9^10^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25^26^27^28^29" "RTN","VADPT0",16,0) I VAN<10,$D(VAHOW),VAHOW[1 S VAS=$P($T(SS+VAN),";;",2) "RTN","VADPT0",17,0) I $D(VAN(1)) F I=1:1:VAN(1) S @VAV@($P(VAS,"^",I))="" "RTN","VADPT0",18,0) Q "RTN","VADPT0",19,0) ; "RTN","VADPT0",20,0) 1 ; -- [DEM] demos "RTN","VADPT0",21,0) D C1,INIT I 'VAERR D 1^VADPT1,13 Q "RTN","VADPT0",22,0) ; "RTN","VADPT0",23,0) 2 ; -- [OPD] other pt vars "RTN","VADPT0",24,0) D C2,INIT,2^VADPT1:'VAERR Q "RTN","VADPT0",25,0) ; "RTN","VADPT0",26,0) 3 ; -- [ADD] current address "RTN","VADPT0",27,0) D C3,INIT,3^VADPT1:'VAERR Q "RTN","VADPT0",28,0) ; "RTN","VADPT0",29,0) 4 ; -- [OAD] other pt vars "RTN","VADPT0",30,0) D C4,INIT,4^VADPT1:'VAERR Q "RTN","VADPT0",31,0) ; "RTN","VADPT0",32,0) 5 ; -- [INP] inpt data -v5 "RTN","VADPT0",33,0) D C5,INIT,5^VADPT2:'VAERR Q "RTN","VADPT0",34,0) ; "RTN","VADPT0",35,0) 6 ; -- [IN5] inpt data v5 "RTN","VADPT0",36,0) D C6,INIT F I=13:1:17 F I1=1:1:7 S @VAV@($P(VAS,"^",I),I1)="" "RTN","VADPT0",37,0) F I=1:1:3 S @VAV@($P(VAS,"^",19),I)="" "RTN","VADPT0",38,0) D 6^VADPT3:'VAERR Q "RTN","VADPT0",39,0) ; "RTN","VADPT0",40,0) 7 ; -- [ELIG] elig data "RTN","VADPT0",41,0) D C7,INIT F I=1:1:6 S @VAV@($P(VAS,"^",5),I)="" "RTN","VADPT0",42,0) D 7^VADPT4:'VAERR Q "RTN","VADPT0",43,0) ; "RTN","VADPT0",44,0) 8 ; -- [MB] $ benefits "RTN","VADPT0",45,0) D C8,INIT D 8^VADPT4:'VAERR Q "RTN","VADPT0",46,0) ; "RTN","VADPT0",47,0) 9 ; -- [SVC] service data "RTN","VADPT0",48,0) D C9,INIT F I=1:1:9 S @VAV@($P(VAS,"^",I),1)="",@VAV@($P(VAS,"^",I),2)="" "RTN","VADPT0",49,0) S @VAV@($P(VAS,"^",10),1)="" "RTN","VADPT0",50,0) F I=11:1:13 S @VAV@($P(VAS,"^",I))=0 "RTN","VADPT0",51,0) S @VAV@($P(VAS,"^",14),1)="" "RTN","VADPT0",52,0) S @VAV@($P(VAS,"^",4),3)="",@VAV@($P(VAS,"^",5),3)="" "RTN","VADPT0",53,0) F I=2,6,7,8 F I1=3,4,5 S @VAV@($P(VAS,"^",I),I1)="" "RTN","VADPT0",54,0) D 9^VADPT4:'VAERR Q "RTN","VADPT0",55,0) ; "RTN","VADPT0",56,0) 10 ; -- [REG] registration data "RTN","VADPT0",57,0) D C10,INIT D 10^VADPT5:'VAERR Q "RTN","VADPT0",58,0) ; "RTN","VADPT0",59,0) 11 ; -- [SDE] clinic enrollment data "RTN","VADPT0",60,0) D C11,INIT D 11^VADPT5:'VAERR Q "RTN","VADPT0",61,0) ; "RTN","VADPT0",62,0) 12 ; -- [SDA] appt data "RTN","VADPT0",63,0) D C12,INIT D 12^VADPT5:'VAERR Q "RTN","VADPT0",64,0) ; "RTN","VADPT0",65,0) 13 ; -- [PID] pt id's "RTN","VADPT0",66,0) S (VA("PID"),VA("BID"))="" D 13^VADPT6:'VAERR Q "RTN","VADPT0",67,0) ; "RTN","VADPT0",68,0) KVAR ; kill all vadpt data "RTN","VADPT0",69,0) K VAN "RTN","VADPT0",70,0) C1 K ^UTILITY("VADM",$J),VADM Q:$D(VAN) "RTN","VADPT0",71,0) C2 K ^UTILITY("VAPD",$J),VAPD Q:$D(VAN) "RTN","VADPT0",72,0) C3 K X S:$D(VAPA("P")) X("P")=VAPA("P") "RTN","VADPT0",73,0) S:$D(VAPA("CD")) X("CD")=VAPA("CD") "RTN","VADPT0",74,0) K ^UTILITY("VAPA",$J),VAPA "RTN","VADPT0",75,0) S:$D(X("P")) VAPA("P")=X("P") K X("P") "RTN","VADPT0",76,0) S:$D(X("CD")) VAPA("CD")=X("CD") K X Q:$D(VAN) "RTN","VADPT0",77,0) C4 K X S:$D(VAOA("A")) X("A")=VAOA("A") "RTN","VADPT0",78,0) K ^UTILITY("VAOA",$J),VAOA "RTN","VADPT0",79,0) S:$D(X("A")) VAOA("A")=X("A") K X Q:$D(VAN) "RTN","VADPT0",80,0) C5 K ^UTILITY("VAIN",$J),VAIN Q:$D(VAN) "RTN","VADPT0",81,0) C6 K X F I="D","E","L","M","V" I $D(VAIP(I)) S X(I)=VAIP(I) "RTN","VADPT0",82,0) S Y=$S('$D(VAIP("V")):"VAIP",VAIP("V")'?1A.E:"VAIP",1:VAIP("V")) K ^UTILITY(Y,$J),@Y "RTN","VADPT0",83,0) F I="D","E","L","M","V" I $D(X(I)) S VAIP(I)=X(I) "RTN","VADPT0",84,0) K X Q:$D(VAN) "RTN","VADPT0",85,0) C7 K ^UTILITY("VAEL",$J),VAEL Q:$D(VAN) "RTN","VADPT0",86,0) C8 K ^UTILITY("VAMB",$J),VAMB Q:$D(VAN) "RTN","VADPT0",87,0) C9 K ^UTILITY("VASV",$J),VASV Q:$D(VAN) "RTN","VADPT0",88,0) C10 K ^UTILITY("VARP",$J) Q:$D(VAN) "RTN","VADPT0",89,0) C11 K ^UTILITY("VAEN",$J) Q:$D(VAN) "RTN","VADPT0",90,0) C12 K ^UTILITY("VASD",$J) Q "RTN","VADPT0",91,0) C13 Q "RTN","VADPT0",92,0) ; "RTN","VADPT0",93,0) SS ; 1^ 2^ 3^ 4^ 5^ 6^ 7^ 8^ 9^10^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25^26^27^28 "RTN","VADPT0",94,0) ;;NM^SS^DB^AG^SX^EX^RE^RA^RP^MS^ET^RC^PL "RTN","VADPT0",95,0) ;;BC^BS^FN^MN^MM^OC^ES^WP "RTN","VADPT0",96,0) ;;L1^L2^L3^CI^ST^ZP^CO^PN^TS^TE^Z4^CCA^CL1^CL2^CL3^CCI^CST^CZP^CCO^CCS^CCE^CTY^PR^PC^CT^CPR^CPC^CCT^CPN "RTN","VADPT0",97,0) ;;L1^L2^L3^CI^ST^ZP^CO^PN^NM^RE^Z4 "RTN","VADPT0",98,0) ;;AN^DR^TS^WL^RB^BS^AD^AT^AF^PT^AP "RTN","VADPT0",99,0) ;;MN^TT^MD^MT^WL^RB^DR^TS^MF^BS^RD^PT^AN^LN^PN^NN^DN^AP^FD "RTN","VADPT0",100,0) ;;EL^PS^SC^VT^IN^TY^CN^ES^MT "RTN","VADPT0",101,0) ;;AA^HB^SS^PE^MR^SI^DI^OR^GI "RTN","VADPT0",102,0) ;;VN^AO^IR^PW^CS^S1^S2^S3^PH^CV^OIF^OEF^UNK^SHD "RTN","VADPT1") 0^8^B50294297 "RTN","VADPT1",1,0) VADPT1 ;ALB/MRL/MJK,ERC,TDM - PATIENT VARIABLES ; 7/17/14 "RTN","VADPT1",2,0) ;;5.3;Registration;**415,489,516,614,688,754,887**;Aug 13, 1993;Build 57 "RTN","VADPT1",3,0) 1 ;Demographic [DEM] "RTN","VADPT1",4,0) N W,Z,NODE "RTN","VADPT1",5,0) ; "RTN","VADPT1",6,0) ; -- name [1 - NM] "RTN","VADPT1",7,0) S VAX=^DPT(DFN,0),@VAV@($P(VAS,"^",1))=$P(VAX,"^") "RTN","VADPT1",8,0) ; "RTN","VADPT1",9,0) ; -- ssn [2 - SS] "RTN","VADPT1",10,0) S Z=$P(VAX,"^",9) S:Z]"" @VAV@($P(VAS,"^",2))=Z_$S(Z]"":"^"_$E(Z,1,3)_"-"_$E(Z,4,5)_"-"_$E(Z,6,10),1:"") "RTN","VADPT1",11,0) ; "RTN","VADPT1",12,0) ; -- date of birth [2 - DB] "RTN","VADPT1",13,0) S Z=$P(VAX,"^",3),Y=Z I Y]"" X ^DD("DD") S @VAV@($P(VAS,"^",3))=Z_"^"_Y "RTN","VADPT1",14,0) ; "RTN","VADPT1",15,0) ; -- age [4 - AG] "RTN","VADPT1",16,0) S W=$S('$D(^DPT(DFN,.35)):"",'^(.35):"",1:+^(.35)) S Y=$S('W:DT,1:W) S:Z]"" @VAV@($P(VAS,"^",4))=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7)) "RTN","VADPT1",17,0) ; "RTN","VADPT1",18,0) ; -- expired date [6 - EX] "RTN","VADPT1",19,0) S (Y,Z)=W X:Y]"" ^DD("DD") S:Z]"" @VAV@($P(VAS,"^",6))=Z_"^"_Y "RTN","VADPT1",20,0) ; "RTN","VADPT1",21,0) ; -- sex [5 - SX] "RTN","VADPT1",22,0) S Z=$P(VAX,"^",2) S:Z]"" @VAV@($P(VAS,"^",5))=Z_"^"_$S(Z="M":"MALE",Z="F":"FEMALE",1:"") K Z "RTN","VADPT1",23,0) ; "RTN","VADPT1",24,0) ; -- remarks [7 - RE] "RTN","VADPT1",25,0) S @VAV@($P(VAS,"^",7))=$P(VAX,"^",10) "RTN","VADPT1",26,0) ; "RTN","VADPT1",27,0) ; -- historic race [8 - RA] "RTN","VADPT1",28,0) S Z=$P(VAX,"^",6),@VAV@($P(VAS,"^",8))=Z_$S($D(^DIC(10,+Z,0)):"^"_$P(^(0),"^"),1:"") "RTN","VADPT1",29,0) ; "RTN","VADPT1",30,0) ; -- religion [9 - RP] "RTN","VADPT1",31,0) S Z=$P(VAX,"^",8),@VAV@($P(VAS,"^",9))=Z_$S($D(^DIC(13,+Z,0)):"^"_$P(^(0),"^"),1:"") "RTN","VADPT1",32,0) ; "RTN","VADPT1",33,0) ; -- marital status [10 - MS] "RTN","VADPT1",34,0) S Z=$P(VAX,"^",5),@VAV@($P(VAS,"^",10))=Z_$S($D(^DIC(11,+Z,0)):"^"_$P(^(0),"^"),1:"") "RTN","VADPT1",35,0) ; "RTN","VADPT1",36,0) ; -- ethnicity [11 - ET] "RTN","VADPT1",37,0) S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.06,X)) Q:'X D "RTN","VADPT1",38,0) .S NODE=$G(^DPT(DFN,.06,X,0)),Z=$P(NODE,"^",1) I Z D "RTN","VADPT1",39,0) ..S @VAV@($P(VAS,"^",11),Y)=Z_"^"_$P($G(^DIC(10.2,Z,0)),"^",1) "RTN","VADPT1",40,0) ..; -- collection method "RTN","VADPT1",41,0) ..S Z=$P(NODE,"^",2) I Z D "RTN","VADPT1",42,0) ...S @VAV@($P(VAS,"^",11),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1) "RTN","VADPT1",43,0) S @VAV@($P(VAS,"^",11))=Y-1 "RTN","VADPT1",44,0) ; "RTN","VADPT1",45,0) ; -- race [12 - RC] "RTN","VADPT1",46,0) S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.02,X)) Q:'X D "RTN","VADPT1",47,0) .S NODE=$G(^DPT(DFN,.02,X,0)),Z=$P(NODE,"^",1) I Z D "RTN","VADPT1",48,0) ..S @VAV@($P(VAS,"^",12),Y)=Z_"^"_$P($G(^DIC(10,Z,0)),"^",1) "RTN","VADPT1",49,0) ..; -- collection method "RTN","VADPT1",50,0) ..S Z=$P(NODE,"^",2) I Z D "RTN","VADPT1",51,0) ...S @VAV@($P(VAS,"^",12),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1) "RTN","VADPT1",52,0) S @VAV@($P(VAS,"^",12))=Y-1 "RTN","VADPT1",53,0) ; "RTN","VADPT1",54,0) ; -- current pt preferred language [13 - LG] "RTN","VADPT1",55,0) N VALANGDT,VAPRFLAN,VALANG0,VAY,VALANGDA,X,Y "RTN","VADPT1",56,0) S VALANGDT=9999999,(VAPRFLAN,VALANG0)="" "RTN","VADPT1",57,0) S VALANGDT=$O(^DPT(DFN,.207,"B",VALANGDT),-1) "RTN","VADPT1",58,0) I VALANGDT="" DO Q "RTN","VADPT1",59,0) .S @VAV@($P(VAS,"^",13))="",@VAV@($P(VAS,"^",13),1)="" "RTN","VADPT1",60,0) S VALANGDA=$O(^DPT(DFN,.207,"B",VALANGDT,0)) "RTN","VADPT1",61,0) S VALANG0=$G(^DPT(DFN,.207,VALANGDA,0)),Y=$P(VALANG0,U),VAPRFLAN=$P(VALANG0,U,2) "RTN","VADPT1",62,0) S (VAY,Y)=VALANGDT X ^DD("DD") S VALANGDT=Y "RTN","VADPT1",63,0) S @VAV@($P(VAS,"^",13))=VAY_"^"_VALANGDT ; FM version^human readable "RTN","VADPT1",64,0) S @VAV@($P(VAS,"^",13),1)=VALANGDA_"^"_VAPRFLAN ; Pointer^human readable "RTN","VADPT1",65,0) Q "RTN","VADPT1",66,0) ; "RTN","VADPT1",67,0) 2 ;Other Patient Variables [OPD] "RTN","VADPT1",68,0) N W,Z "RTN","VADPT1",69,0) S VAX=^DPT(DFN,0) "RTN","VADPT1",70,0) ; "RTN","VADPT1",71,0) ; -- city of birth [1 - BC] "RTN","VADPT1",72,0) S @VAV@($P(VAS,"^",1))=$P(VAX,"^",11) "RTN","VADPT1",73,0) ; "RTN","VADPT1",74,0) ; -- state of birth [2 - BS] "RTN","VADPT1",75,0) S Z=$P(VAX,"^",12),@VAV@($P(VAS,"^",2))=Z_$S($D(^DIC(5,+Z,0)):"^"_$P(^(0),"^",1),1:"") "RTN","VADPT1",76,0) ; "RTN","VADPT1",77,0) ; -- occupation [6 - OC] "RTN","VADPT1",78,0) S @VAV@($P(VAS,"^",6))=$P(VAX,"^",7) "RTN","VADPT1",79,0) ; "RTN","VADPT1",80,0) ; -- names "RTN","VADPT1",81,0) S VAX=$S($D(^DPT(DFN,.24)):^(.24),1:"") "RTN","VADPT1",82,0) S @VAV@($P(VAS,"^",3))=$P(VAX,"^",1) ; father's [3 - FN] "RTN","VADPT1",83,0) S @VAV@($P(VAS,"^",4))=$P(VAX,"^",2) ; mother's [4 - MN] "RTN","VADPT1",84,0) S @VAV@($P(VAS,"^",5))=$P(VAX,"^",3) ; mother's maiden [5 - MM] "RTN","VADPT1",85,0) ; "RTN","VADPT1",86,0) ; -- employment status [7 - ES] "RTN","VADPT1",87,0) S VAX=$S($D(^DPT(DFN,.311)):^(.311),1:""),W="EMPLOYED FULL TIME^EMPLOYED PART TIME^NOT EMPLOYED^SELF EMPLOYED^RETIRED^ACTIVE MILITARY DUTY^UNKNOWN" "RTN","VADPT1",88,0) S Z=$P(VAX,"^",15),@VAV@($P(VAS,"^",7))=Z_$S(Z:"^"_$P(W,"^",Z),1:"") "RTN","VADPT1",89,0) ; "RTN","VADPT1",90,0) ; -- PHONE NUMBER [WORK] [8 - WP] "RTN","VADPT1",91,0) I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,"^",8))=$P(^(.13),"^",2) "RTN","VADPT1",92,0) Q "RTN","VADPT1",93,0) ; "RTN","VADPT1",94,0) 3 ;Address [ADD] "RTN","VADPT1",95,0) N VAFOR "RTN","VADPT1",96,0) S VABEG=$S($D(VATEST("ADD",9)):VATEST("ADD",9),1:DT),VAEND=$S($D(VATEST("ADD",10)):VATEST("ADD",10),1:DT) "RTN","VADPT1",97,0) I $S($D(VAPA("P")):1,'$D(^DPT(DFN,.121)):1,$P(^(.121),"^",9)'="Y":1,'$P(^(.121),"^",7):1,$P(^(.121),"^",7)>VABEG:1,'$P(^(.121),"^",8):0,1:$P(^(.121),"^",8)VAACTDT)!(VAEND&(VAEND6:1,1:0) S VAX=.21,VAOA("A")=7 "RTN","VADPT1",152,0) E S VAX="."_$P("33^34^211^331^311^25","^",+VAOA("A")) "RTN","VADPT1",153,0) S VAX(1)=VAX,VAX=$S($D(^DPT(DFN,VAX(1))):^(VAX(1)),1:"") I VAX(1)=.25 S VAX=$P(VAX,"^",1)_"^^"_$P(VAX,"^",2,99) "RTN","VADPT1",154,0) S VAX(2)=0 F I=3,4,5,6,7,8 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I) "RTN","VADPT1",155,0) S @VAV@($P(VAS,"^",7))="",@VAV@($P(VAS,"^",8))=$P(VAX,"^",9),VAX(2)=8 "RTN","VADPT1",156,0) F I=1,2 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I) "RTN","VADPT1",157,0) I "^.311^.25"[("^"_VAX(1)_"^") S @VAV@($P(VAS,"^",10))="" "RTN","VADPT1",158,0) S VAZ=@VAV@($P(VAS,"^",5)) I VAZ,$D(^DIC(5,+VAZ,0)) S VAZ(1)=$P(^(0),"^",1),@VAV@($P(VAS,"^",5))=VAZ_"^"_VAZ(1) "RTN","VADPT1",159,0) S VAZIP4=$P($G(^DPT(DFN,.22)),U,VAOA("A")) "RTN","VADPT1",160,0) S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_"-"_$E(VAZIP4,6,9)) "RTN","VADPT1",161,0) Q "UP",2,2.07,-1) 2^.207 "UP",2,2.07,0) 2.07 "VER") 8.0^22.2 "^DD",2,2,7,0) LANGUAGE DATE/TIME^2.07IDA^^.207;0 "^DD",2,2,7,21,0) ^^2^2^3160418^ "^DD",2,2,7,21,1,0) These are the dates/times the preferred language information was given "^DD",2,2,7,21,2,0) by the patient and recorded in the Patient File. "^DD",2,2,7,"DT") 3160330 "^DD",2,2.07,0) LANGUAGE DATE/TIME SUB-FIELD^I^.02^2 "^DD",2,2.07,0,"DT") 3170221 "^DD",2,2.07,0,"IX","B",2.07,.01) "^DD",2,2.07,0,"NM","LANGUAGE DATE/TIME") "^DD",2,2.07,0,"UP") 2 "^DD",2,2.07,.01,0) LANGUAGE DATE/TIME^RDX^^0;1^S %DT="ETXR",%DT(0)="-NOW" D ^%DT S X=Y K:Y<1 X K %DT(0) "^DD",2,2.07,.01,1,0) ^.1 "^DD",2,2.07,.01,1,1,0) 2.07^B "^DD",2,2.07,.01,1,1,1) S ^DPT(DA(1),.207,"B",$E(X,1,30),DA)="" "^DD",2,2.07,.01,1,1,2) K ^DPT(DA(1),.207,"B",$E(X,1,30),DA) "^DD",2,2.07,.01,3) Enter the date and time the preferred language information was recorded. You may use N or n for 'NOW'. Future values may not be entered. "^DD",2,2.07,.01,4) N DPTX S DPTX="This field entry must be today's date or earlier and must include a time." D EN^DDIOL(DPTX),EN^DDIOL("") "^DD",2,2.07,.01,21,0) ^^4^4^3160418^ "^DD",2,2.07,.01,21,1,0) "^DD",2,2.07,.01,21,2,0) "^DD",2,2.07,.01,21,3,0) The date/time the preferred language information was given by the "^DD",2,2.07,.01,21,4,0) patient and recorded in the Patient File. "^DD",2,2.07,.01,"DT") 3160418 "^DD",2,2.07,.02,0) PREFERRED LANGUAGE^RFXJ60^^0;2^D INPXF207^DGRPE "^DD",2,2.07,.02,3) Your answer must be 1-60 characters in length. If the patient wishes not to give a preferred language or declines to answer, enter an * (asterisk) at the prompt to respond as 'DECLINED TO ANSWER'. "^DD",2,2.07,.02,4) D XHELP207^DGRPE "^DD",2,2.07,.02,21,0) ^^6^6^3160418^ "^DD",2,2.07,.02,21,1,0) This is the preferred language of the patient. A patient may speak, "^DD",2,2.07,.02,21,2,0) read and write several languages but this is the one that he/she "^DD",2,2.07,.02,21,3,0) prefers. "^DD",2,2.07,.02,21,4,0) "^DD",2,2.07,.02,21,5,0) You may also answer with the 2- or 3-letter code assigned to the "^DD",2,2.07,.02,21,6,0) language or type in the language name. "^DD",2,2.07,.02,23,0) ^.001^4^4^3140731^^^^ "^DD",2,2.07,.02,23,1,0) Any language selected for this field is screened to be a "living" language "^DD",2,2.07,.02,23,2,0) and to have a 2-character code included. This facilitates selection of "^DD",2,2.07,.02,23,3,0) languages based on whether it is used today or not and if it has the "^DD",2,2.07,.02,23,4,0) information needed. "^DD",2,2.07,.02,"DT") 3160418 **INSTALL NAME** SD*5.3*619 "BLD",9878,0) SD*5.3*619^SCHEDULING^0^3170223^y "BLD",9878,1,0) ^^2^2^3140709^^ "BLD",9878,1,1,0) This patch allows capturing of language data during the making of an "BLD",9878,1,2,0) appointment if no value is on file. "BLD",9878,4,0) ^9.64PA^^ "BLD",9878,6.3) 35 "BLD",9878,"ABPKG") n "BLD",9878,"KRN",0) ^9.67PA^779.2^20 "BLD",9878,"KRN",.4,0) .4 "BLD",9878,"KRN",.401,0) .401 "BLD",9878,"KRN",.402,0) .402 "BLD",9878,"KRN",.403,0) .403 "BLD",9878,"KRN",.5,0) .5 "BLD",9878,"KRN",.84,0) .84 "BLD",9878,"KRN",3.6,0) 3.6 "BLD",9878,"KRN",3.8,0) 3.8 "BLD",9878,"KRN",9.2,0) 9.2 "BLD",9878,"KRN",9.8,0) 9.8 "BLD",9878,"KRN",9.8,"NM",0) ^9.68A^1^1 "BLD",9878,"KRN",9.8,"NM",1,0) SDM^^0^B36241723 "BLD",9878,"KRN",9.8,"NM","B","SDM",1) "BLD",9878,"KRN",19,0) 19 "BLD",9878,"KRN",19,"NM",0) ^9.68A^^ "BLD",9878,"KRN",19.1,0) 19.1 "BLD",9878,"KRN",101,0) 101 "BLD",9878,"KRN",409.61,0) 409.61 "BLD",9878,"KRN",771,0) 771 "BLD",9878,"KRN",779.2,0) 779.2 "BLD",9878,"KRN",870,0) 870 "BLD",9878,"KRN",8989.51,0) 8989.51 "BLD",9878,"KRN",8989.52,0) 8989.52 "BLD",9878,"KRN",8994,0) 8994 "BLD",9878,"KRN","B",.4,.4) "BLD",9878,"KRN","B",.401,.401) "BLD",9878,"KRN","B",.402,.402) "BLD",9878,"KRN","B",.403,.403) "BLD",9878,"KRN","B",.5,.5) "BLD",9878,"KRN","B",.84,.84) "BLD",9878,"KRN","B",3.6,3.6) "BLD",9878,"KRN","B",3.8,3.8) "BLD",9878,"KRN","B",9.2,9.2) "BLD",9878,"KRN","B",9.8,9.8) "BLD",9878,"KRN","B",19,19) "BLD",9878,"KRN","B",19.1,19.1) "BLD",9878,"KRN","B",101,101) "BLD",9878,"KRN","B",409.61,409.61) "BLD",9878,"KRN","B",771,771) "BLD",9878,"KRN","B",779.2,779.2) "BLD",9878,"KRN","B",870,870) "BLD",9878,"KRN","B",8989.51,8989.51) "BLD",9878,"KRN","B",8989.52,8989.52) "BLD",9878,"KRN","B",8994,8994) "BLD",9878,"QDEF") ^^^^NO^^^^NO^^NO "BLD",9878,"QUES",0) ^9.62^^ "BLD",9878,"REQB",0) ^9.611^3^2 "BLD",9878,"REQB",2,0) SD*5.3*441^1 "BLD",9878,"REQB",3,0) VA FILEMAN 22.2^1 "BLD",9878,"REQB","B","SD*5.3*441",2) "BLD",9878,"REQB","B","VA FILEMAN 22.2",3) "MBREQ") 0 "PKG",16,-1) 1^1 "PKG",16,0) SCHEDULING^SD^APPOINTMENTS,PROFILES,LETTERS,AMIS REPORTS "PKG",16,20,0) ^9.402P^^ "PKG",16,22,0) ^9.49I^1^1 "PKG",16,22,1,0) 5.3^2930813^2930824 "PKG",16,22,1,"PAH",1,0) 619^3170223^53 "PKG",16,22,1,"PAH",1,1,0) ^^2^2^3170223 "PKG",16,22,1,"PAH",1,1,1,0) This patch allows capturing of language data during the making of an "PKG",16,22,1,"PAH",1,1,2,0) appointment if no value is on file. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 1 "RTN","SDM") 0^1^B36241723 "RTN","SDM",1,0) SDM ;SF/GFT,ALB/BOK - MAKE AN APPOINTMENT ; 22 Jul 2016 4:33 PM "RTN","SDM",2,0) ;;5.3;Scheduling;**15,32,38,41,44,79,94,167,168,218,223,250,254,296,380,478,441,619**;Aug 13, 1993;Build 35 "RTN","SDM",3,0) ; If defined... "RTN","SDM",4,0) ; appt mgt vars: SDFN := DFN of patient....will not be asked "RTN","SDM",5,0) ; SDCLN := ifn of clinic.....will not be asked "RTN","SDM",6,0) ; SDAMERR := returned if error occurs "RTN","SDM",7,0) ; "RTN","SDM",8,0) ; Reference to LANGDEL^DGRPE supported by DBIA #6405 "RTN","SDM",9,0) ; Reference to ^DPT(DFN,.207) supported by DBIA #6406 "RTN","SDM",10,0) ; "RTN","SDM",11,0) S:'$D(SDMM) SDMM=0 "RTN","SDM",12,0) EN1 L W !! D I^SDUTL I '$D(SDCLN) S DIC="^SC(",DIC(0)="AEMZQ",DIC("A")="Select CLINIC: ",DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS""))" D ^DIC K DIC G:Y<0!'$D(^("SL")) END "RTN","SDM",13,0) N SDRES S:$D(SDCLN) Y=+SDCLN S SDRES=$$CLNCK^SDUTL2(+Y,1) "RTN","SDM",14,0) I 'SDRES W !,?5,"Clinic MUST be corrected before continuing." G END:$D(SDCLN),SDM "RTN","SDM",15,0) K SDAPTYP,SDIN,SDRE,SDXXX S:$D(SDCLN) Y=+SDCLN "RTN","SDM",16,0) S TMPYCLNC=Y,STPCOD=$P($G(^SC(+TMPYCLNC,0)),U,7) ;SD/478 "RTN","SDM",17,0) I $D(^SC(+Y,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),U,2) "RTN","SDM",18,0) K SDINA I $D(SDIN),SDIN S SDINA=SDIN K SDIN "RTN","SDM",19,0) I $D(SD),$D(SC),+Y'=+SC K SD "RTN","SDM",20,0) S SL=$G(^SC(+Y,"SL")),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SC=Y,SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X=1:X,X:X,1:4),SI=$S(X="":4,X<3:4,X:X,1:4),STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2) K Y "RTN","SDM",21,0) I $D(^SC(+SC,"SDPROT")),$P(^("SDPROT"),U)="Y",'$D(^SC(+SC,"SDPRIV",DUZ)) W !,*7,"Access to ",$$CNAM(+SC)," is prohibited!",!,"Only users with a special code may access this clinic.",*7 S:$D(SDCLN) SDAMERR="" G END:$D(SDCLN),SDM "RTN","SDM",22,0) D CS^SDM1A S SDW="",WY="Y" "RTN","SDM",23,0) I '$D(ORACTION),'$D(SDFN) S (DIC,DIE)="^DPT(",DIC(0)="AQZME" D ^DIC S DFN=+Y G:Y<0 END:$D(SDCLN),^SDM0:X[U,SDM "RTN","SDM",24,0) S:$D(SDFN) DFN=SDFN "RTN","SDM",25,0) I $D(^DPT(DFN,.35)),$P(^(.35),U)]"" W !?10,*7,"PATIENT HAS DIED." S:$D(SDFN) SDAMERR="" G END:$D(SDFN),SDM "RTN","SDM",26,0) D ^SDM4 I $S('$D(COLLAT):1,COLLAT=7:1,1:0) G:$D(SDCLN) END G SDM "RTN","SDM",27,0) ;-- get sub-category for appointment type "RTN","SDM",28,0) S SDXSCAT=$$SUB^DGSAUTL(SDAPTYP,2,"") "RTN","SDM",29,0) K SDXXX D EN G END:$D(SDCLN),SDM "RTN","SDM",30,0) EN K SDMLT1 W:$P(VAEL(9),U,2)]"" !!,?15,"MEANS TEST STATUS: ",$P(VAEL(9),U,2),! "RTN","SDM",31,0) ; *** sck, mt blocking removed "RTN","SDM",32,0) ;S X="EASMTCHK" X ^%ZOSF("TEST") I $T,$$MT^EASMTCHK(DFN,+$G(SDAPTYP),"M") S SDAMERR="" Q "RTN","SDM",33,0) S Y=DFN,Y(0)=^DPT(DFN,0) I VADM(7)]"" W !?3,*7,VADM(7) "RTN","SDM",34,0) I $D(^DGS(41.1,"B",DFN)) F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) Q:I'>0 I $P(^DGS(41.1,I,0),U,2)'DT !,"NO PENDING APPOINTMENTS" "RTN","SDM",36,0) I $O(^DPT(DFN,"S",DT))>DT D G END:%<0,HELP:'% "RTN","SDM",37,0) .S %=1 W !,"DISPLAY PENDING APPOINTMENTS:" "RTN","SDM",38,0) .D YN^DICN "RTN","SDM",39,0) .I %Y["^" S SDMLT1=1 "RTN","SDM",40,0) D:%=1 "RTN","SDM",41,0) .N DX,DY,SDXY,SDEND S SDXY="S DX=$X,DY=0"_$S($L($G(^%ZOSF("XY"))):" "_^("XY"),1:"") X SDXY "RTN","SDM",42,0) .S CN=1 "RTN","SDM",43,0) .F Y=DT:0 S Y=$O(^DPT(DFN,"S",Y)) Q:Y'>0 I "I"[$P(^(Y,0),U,2) X:(($Y+4)>IOSL) "D OUT^SDUTL X SDXY" Q:$G(SDEND) D CHKSO W:$X>9 ! W CN,".",?4 D DT^SDM0 W ?23 S DA=+SSC W SDLN,$S($D(^SC(DA,0)):$P(^(0),U),1:"DELETED CLINIC "),COV," ",SDAT16 D "RTN","SDM",44,0) ..S CNIEN=0 F S CNIEN=$O(^SC(+SSC,"S",HY,1,CNIEN)) Q:'+CNIEN S CNPAT=$P($G(^SC(+SSC,"S",HY,1,CNIEN,0)),U) I CNPAT=DFN W:+$G(^SC(+SSC,"S",HY,1,CNIEN,"CONS")) " Consult Appt." S CN=CN+1 Q ;SD/478 "RTN","SDM",45,0) ;Prompt for ETHNICITY if no value on file "RTN","SDM",46,0) I '$O(^DPT(DFN,.06,0)) D "RTN","SDM",47,0) .S DA=DFN,DR="6ETHNICITY",DIE="^DPT(" "RTN","SDM",48,0) .S DR(2,2.06)=".01ETHNICITY" "RTN","SDM",49,0) .D ^DIE K DR "RTN","SDM",50,0) ;Prompt for RACE if no value on file "RTN","SDM",51,0) I '$O(^DPT(DFN,.02,0)) D "RTN","SDM",52,0) .S DA=DFN,DR="2RACE",DIE="^DPT(" "RTN","SDM",53,0) .S DR(2,2.02)=".01RACE" "RTN","SDM",54,0) .D ^DIE K DR "RTN","SDM",55,0) ;Prompt for Language if no value on file ;*///* "RTN","SDM",56,0) I '$O(^DPT(DFN,.207,0)) D "RTN","SDM",57,0) .S DA=DFN,DIE="^DPT(",DR="7LANGUAGE DATE/TIME;",DR(2,2.07)=".02//ENGLISH" "RTN","SDM",58,0) .D ^DIE K DR "RTN","SDM",59,0) .D LANGDEL^DGRPE ; check if no language entered "RTN","SDM",60,0) I $S('$D(^DPT(DFN,.11)):1,$P(^(.11),U)="":1,1:0) N FLG S FLG(1)=1 D EN^DGREGAED(DFN,.FLG) "RTN","SDM",61,0) Q:$D(SDXXX) "RTN","SDM",62,0) E S Y=$P(SL,U,5) "RTN","SDM",63,0) S SDW="" I $D(^DPT(DFN,.1)) S SDW=^(.1) W !,"NOTE - PATIENT IS NOW IN WARD "_SDW "RTN","SDM",64,0) Q:$D(SDXXX) "RTN","SDM",65,0) EN2 F X=0:0 S X=$O(^DPT(DFN,"DE",X)) Q:'$D(^(+X,0)) I ^(0)-SC=0!'(^(0)-Y) F XX=0:0 S XX=$O(^DPT(DFN,"DE",X,1,XX)) Q:XX<1 S SDDIS=$P(^(XX,0),U,3) I 'SDDIS D:'$D(SDMULT) A^SDCNSLT G ^SDM0 "RTN","SDM",66,0) I '$D(^SC(+Y,0)) S Y=+SC "RTN","SDM",67,0) S Y=$P(^SC(Y,0),U) "RTN","SDM",68,0) ; SCRESTA = Array of pt's teams causing restricted consults "RTN","SDM",69,0) N SCRESTA "RTN","SDM",70,0) S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA") "RTN","SDM",71,0) IF SCREST D "RTN","SDM",72,0) .N SCTM "RTN","SDM",73,0) . S SCCLNM=Y "RTN","SDM",74,0) . W !,?5,"Patient has restricted consults due to team assignment(s):" "RTN","SDM",75,0) .S SCTM=0 "RTN","SDM",76,0) .F S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM W !,?10,SCRESTA(SCTM) "RTN","SDM",77,0) IF SCREST&'$G(SCOKCONS) D Q "RTN","SDM",78,0) .W !,?5,"This patient may only be given appointments and enrolled in clinics via" "RTN","SDM",79,0) .W !,?15,"Make Consult Appointment Option, and" "RTN","SDM",80,0) .W !,?15,"Edit Clinic Enrollment Data option" "RTN","SDM",81,0) D:$G(SCREST) MAIL^SCMCCON(DFN,.SCCLNM,2,DT,"SCRESTA") "RTN","SDM",82,0) K DR,SCREST,SCCLNM "RTN","SDM",83,0) D:'$D(SDMULT) ^SDCNSLT ;SD/478 "RTN","SDM",84,0) G ^SDM0 "RTN","SDM",85,0) ; "RTN","SDM",86,0) CHKSO S COV=$S($P(^DPT(DFN,"S",Y,0),U,11)=1:" (COLLATERAL)",1:""),HY=Y,SSC=^(0),SDAT16=$S($D(^SD(409.1,+$P(SSC,U,16),0)):$P(^(0),U),1:"") "RTN","SDM",87,0) F SDJ=3,4,5 I $P(^DPT(DFN,"S",HY,0),U,SDJ)]"" S Y=$P(^(0),U,SDJ) W:$X>9 ! W ?10,"*" D DT^SDM0 W ?32,$S(SDJ=3:"LAB",SDJ=4:"XRAY",1:"EKG") "RTN","SDM",88,0) S SDLN="" F J=0:0 S J=$O(^SC(+SSC,"S",HY,1,J)) Q:'J I $D(^(J,0)),+^(0)=DFN S SDLN="("_$P(^(0),U,2)_" MIN) " Q "RTN","SDM",89,0) S Y=HY Q "RTN","SDM",90,0) ; "RTN","SDM",91,0) END D KVAR^VADPT K SDAPTYP,SDSC,%,%DT,ASKC,COV,DA,DIC,DIE,DP,DR,HEY,HSI,HY,J,SB,SC,SDDIF,SDJ,SDLN,SD17,SDMAX,SDU,SDYC,SI,SL,SSC,STARTDAY,STR "RTN","SDM",92,0) K WY,X,XX,Y,S,SD,SDAP16,SDEDT,SDTY,SM,SS,ST,ARG,CCX,CCXN,HX,I,PXR,SDINA,SDW,COLLAT,SDDIS I $D(SDMM) K:'SDMM SDMM "RTN","SDM",93,0) K A,CC,CLNIEN,CN,CNIEN,CNPAT,CNSLTLNK,CNSULT,CNT,CONS,CPRSTAT,CW,DSH,DTENTR,DTIN,DTLMT,DTR,ND,P8,PROC,PT,PTIEN,PTNM,RTMP,NOSHOW,SCPTTM,SD1,SDAMSCN,SDATE,SDDOT,SDII,SDINC,SDINCM,SDLEN,SDNS,SDSI,SDST,SDSTR,SDSTRTDT "RTN","SDM",94,0) K SDXSCAT,SENDER,SERVICE,SRV,STATUS,STPCOD,TMP,TMPYCLNC,TYPE "RTN","SDM",95,0) I '$D(SDMLT) K SDMLT1 "RTN","SDM",96,0) Q "RTN","SDM",97,0) ; "RTN","SDM",98,0) OERR S XQORQUIT=1 Q:'$D(ORVP) S DFN=+ORVP G SDM "RTN","SDM",99,0) ; "RTN","SDM",100,0) HELP W !,"YES - TO DISPLAY FUTURE APPOINTMENTS",!,"NO - FUTURE APPOINTMENTS NOT DISPLAYED" G PEND "RTN","SDM",101,0) ; "RTN","SDM",102,0) CNAM(SDCL) ;Return clinic name "RTN","SDM",103,0) ;Input: SDCL=clinic ien "RTN","SDM",104,0) N SDX "RTN","SDM",105,0) S SDX=$P($G(^SC(+SDCL,0)),U) "RTN","SDM",106,0) Q $S($L(SDX):SDX,1:"this clinic") "VER") 8.0^22.2 **END** **END**