- SDRRTSK1 ;10N20/MAH - Recall Reminder-Clinic Print Task ;09/07/17
- ;;5.3;Scheduling;**536,579,643,654,685**;Aug 13, 1993;Build 3
- ;;This routine is called from SDRR TASK JOB CARD
- ;;and will be called if PARAM IS cards
- ;
- ; SD*654
- ; - fixes incomplete Canadian address.
- ;
- START Q:'$D(^SD(403.53,0))
- S CRP=0
- F S CRP=$O(^SD(403.53,CRP)) Q:'CRP D
- .S TYPE=$P($G(^SD(403.53,CRP,0)),"^",2)
- .Q:TYPE["L"
- .S DATE=$P($G(^SD(403.53,CRP,0)),"^",4) Q:DATE="" ;IF NOT SET ROUTINE WILL QUIT
- .S X="T+"_DATE D ^%DT S (ZSDT,ZEDT)=Y K Y
- .S (PRT,TEAM)=0
- .F S TEAM=$O(^SD(403.55,"C",CRP,TEAM)) Q:TEAM="" S PRT=$P($G(^SD(403.55,TEAM,0)),"^",3) D
- ..Q:PRT=""
- ..S DA=PRT
- ..S DIC="^%ZIS(1,",DR=".01;1;3",DIQ="DPTR",DIQ(0)="I" D EN^DIQ1
- ..N IOP S IOP=$G(DPTR("3.5",DA,".01","I")) D ^%ZIS
- ..S PROV=0 F S PROV=$O(^SD(403.54,"C",TEAM,PROV)) Q:PROV="" D
- ...S D0=0 F S D0=$O(^SD(403.5,"C",PROV,D0)) Q:D0="" D
- ....; SD*579 - if entry not exist, kill x-refs and quit
- ....I '$D(^SD(403.5,D0)) D KXREF Q
- ....S DTA=$G(^SD(403.5,D0,0))
- ....S TIME=""
- ....I $P($G(^SD(403.5,D0,0)),"^",9)>45 S TIME=$P($G(^SD(403.5,D0,0)),"^",9) S TIME="**"_TIME_"**"
- ....S LAB=$S($P($G(^SD(403.5,D0,0)),"^",8)="f":"**FL",$P(^SD(403.5,D0,0),"^",8)="n":"**NFL",1:"")
- ....S DFN=+DTA
- ....;Q:$P(DTA,U,6)<ZSDT!($P(DTA,U,6)>ZEDT)
- ....Q:$P(DTA,U,6)>ZEDT ;alb/sat 643
- ....Q:$P(DTA,U,10)'="" ;alb/sat 643
- ....Q:$$TESTPAT^VADPT(DFN)
- ....D ADD^VADPT,DEM^VADPT
- ....S STATE=$P(VAPA(5),"^",1),STATE=$$GET1^DIQ(5,STATE_",",1)
- ....S PN=$P(VADM(1),U)
- ....I $G(VADM(6),U)'="" Q
- ....N CHECK
- ....I $$BADADR^DGUTL3(DFN) S CHECK=1 S XMSUB="Bad Address for Recall Reminder Patient",XMTEXT="SDRR(" D
- .....S XMY("G.SDRR BAD ADDRESS")="",XMDUZ=.5
- .....S SDRR(1)="Bad Address- card will not be printed for:"_" "_PN_" "_VA("BID")
- .....D ^XMD
- .....K XMY,XMSUB,XMTEXT,XMDUZ
- .....Q
- .....;ADDED THE DATE INFORMATION
- ....I '$D(CHECK) S $P(^SD(403.5,D0,0),"^",10)=DT
- ....Q:$D(CHECK)
- ....U IO
- ....W @IOF F L=1:1:7 W !
- ....S PNAME=$$NAMEFMT^XLFNAME(PN,"G","")
- ....W !?20,PNAME
- ....D ADDR ; SD*654 fix incomplete addr
- ....I TIME'="" W !!?45,TIME
- ....I LAB'="" W !,?45,LAB
- ..D ^%ZISC
- K DPTR,DEVSB,DEVSB1,DIQ,DEVSB1,DA,DA1,DR
- QUIT K DEV,PRT,ADTA,D0,DFN,DIC,DIR,DIRUT,DTA,I,L,PN,POP,Y,ZDIV,ZEDT,ZPR,ZSDT,FAST,TIME,ACC,TYPE,PTN,CRP,STATE,PNAME
- K LINE,LETTER,MESSAGE,TEST,CLINIC,DA,DATE,DEV1,DEVSB,DOD,FAIL,PROV,TEAM,X,DPT,LAB,SDRR,VA,LAB,DPT,SDRR,VA
- D KVAR^VADPT
- Q
- ;
- KXREF ; SD*579 - If entry does not exist, kill all the x-refs.
- S STR="BCDE"
- F I=1:1:$L(STR) D
- .S X=$E(STR,I,I)
- .S N3=0 F S N3=$O(^SD(403.5,X,N3)) Q:N3'>0 D
- ..S N4=0 F S N4=$O(^SD(403.5,X,N3,N4)) Q:N4'>0 D
- ...I N4=D0 K ^SD(403.5,X,N3,N4)
- K I,STR,X,N3,N4
- Q
- ;
- ADDR ; SD*654 Patient address
- ; Change state to abbr.
- N SDRRIENS,SDRRX
- I $D(VAPA(5)) S SDRRIENS=+VAPA(5)_",",SDRRX=$$GET1^DIQ(5,SDRRIENS,1),$P(VAPA(5),U,2)=SDRRX
- I $D(VAPA(17)) S SDRRIENS=+VAPA(17)_",",SDRRX=$$GET1^DIQ(5,SDRRIENS,1),$P(VAPA(17),U,2)=SDRRX
- K SDRRIENS,SDRRX
- ;
- N SDRRACT1,SDRRACT2,LL
- ; Check Confidential Address Indicator (0=Inactive,1=Active)
- S SDRRACT1=VAPA(12),SDRRACT2=$P($G(VAPA(22,2)),U,3)
- ; If Confidential address is not active, print regular address
- I ($G(SDRRACT1)=0)!($G(SDRRACT2)'="Y") D
- . F LL=1:1:3 W:VAPA(LL)]"" !,?20,VAPA(LL)
- . ; If country is blank, display as USA
- . I (VAPA(25)="")!($P(VAPA(25),U,2)="UNITED STATES") D
- . . ; Display city, state, zip
- . . W !?20,VAPA(4)_" "_$P(VAPA(5),U,2)_" "_$P(VAPA(11),U,2)
- . E D
- . . ; Display city, province, postal code
- . . W !?20,VAPA(4)_" "_VAPA(23)_" "_VAPA(24)
- . ; Display country
- . W:($P(VAPA(25),U,2)'="UNITED STATES") !,?20,$P(VAPA(25),U,2)
- ; If Confidential address is active, print confidential address
- I $G(SDRRACT1)=1,$G(SDRRACT2)="Y" D
- . F LL=13:1:15 W:VAPA(LL)]"" !,?20,VAPA(LL) ;*685
- . I (VAPA(28)="")!($P(VAPA(28),"^",2)="UNITED STATES") D
- . . W !,?20,VAPA(16)_" "_$P(VAPA(17),U,2)_" "_$P(VAPA(18),U,2)
- . E D
- . . W !,?20,VAPA(27)_" "_VAPA(16)_" "_VAPA(26)
- . I ($P(VAPA(28),"^",2)'="UNITED STATES") W !?20,$P(VAPA(28),U,2)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDRRTSK1 4164 printed Feb 19, 2025@00:27:29 Page 2
- SDRRTSK1 ;10N20/MAH - Recall Reminder-Clinic Print Task ;09/07/17
- +1 ;;5.3;Scheduling;**536,579,643,654,685**;Aug 13, 1993;Build 3
- +2 ;;This routine is called from SDRR TASK JOB CARD
- +3 ;;and will be called if PARAM IS cards
- +4 ;
- +5 ; SD*654
- +6 ; - fixes incomplete Canadian address.
- +7 ;
- START if '$DATA(^SD(403.53,0))
- QUIT
- +1 SET CRP=0
- +2 FOR
- SET CRP=$ORDER(^SD(403.53,CRP))
- if 'CRP
- QUIT
- Begin DoDot:1
- +3 SET TYPE=$PIECE($GET(^SD(403.53,CRP,0)),"^",2)
- +4 if TYPE["L"
- QUIT
- +5 ;IF NOT SET ROUTINE WILL QUIT
- SET DATE=$PIECE($GET(^SD(403.53,CRP,0)),"^",4)
- if DATE=""
- QUIT
- +6 SET X="T+"_DATE
- DO ^%DT
- SET (ZSDT,ZEDT)=Y
- KILL Y
- +7 SET (PRT,TEAM)=0
- +8 FOR
- SET TEAM=$ORDER(^SD(403.55,"C",CRP,TEAM))
- if TEAM=""
- QUIT
- SET PRT=$PIECE($GET(^SD(403.55,TEAM,0)),"^",3)
- Begin DoDot:2
- +9 if PRT=""
- QUIT
- +10 SET DA=PRT
- +11 SET DIC="^%ZIS(1,"
- SET DR=".01;1;3"
- SET DIQ="DPTR"
- SET DIQ(0)="I"
- DO EN^DIQ1
- +12 NEW IOP
- SET IOP=$GET(DPTR("3.5",DA,".01","I"))
- DO ^%ZIS
- +13 SET PROV=0
- FOR
- SET PROV=$ORDER(^SD(403.54,"C",TEAM,PROV))
- if PROV=""
- QUIT
- Begin DoDot:3
- +14 SET D0=0
- FOR
- SET D0=$ORDER(^SD(403.5,"C",PROV,D0))
- if D0=""
- QUIT
- Begin DoDot:4
- +15 ; SD*579 - if entry not exist, kill x-refs and quit
- +16 IF '$DATA(^SD(403.5,D0))
- DO KXREF
- QUIT
- +17 SET DTA=$GET(^SD(403.5,D0,0))
- +18 SET TIME=""
- +19 IF $PIECE($GET(^SD(403.5,D0,0)),"^",9)>45
- SET TIME=$PIECE($GET(^SD(403.5,D0,0)),"^",9)
- SET TIME="**"_TIME_"**"
- +20 SET LAB=$SELECT($PIECE($GET(^SD(403.5,D0,0)),"^",8)="f":"**FL",$PIECE(^SD(403.5,D0,0),"^",8)="n":"**NFL",1:"")
- +21 SET DFN=+DTA
- +22 ;Q:$P(DTA,U,6)<ZSDT!($P(DTA,U,6)>ZEDT)
- +23 ;alb/sat 643
- if $PIECE(DTA,U,6)>ZEDT
- QUIT
- +24 ;alb/sat 643
- if $PIECE(DTA,U,10)'=""
- QUIT
- +25 if $$TESTPAT^VADPT(DFN)
- QUIT
- +26 DO ADD^VADPT
- DO DEM^VADPT
- +27 SET STATE=$PIECE(VAPA(5),"^",1)
- SET STATE=$$GET1^DIQ(5,STATE_",",1)
- +28 SET PN=$PIECE(VADM(1),U)
- +29 IF $GET(VADM(6),U)'=""
- QUIT
- +30 NEW CHECK
- +31 IF $$BADADR^DGUTL3(DFN)
- SET CHECK=1
- SET XMSUB="Bad Address for Recall Reminder Patient"
- SET XMTEXT="SDRR("
- Begin DoDot:5
- +32 SET XMY("G.SDRR BAD ADDRESS")=""
- SET XMDUZ=.5
- +33 SET SDRR(1)="Bad Address- card will not be printed for:"_" "_PN_" "_VA("BID")
- +34 DO ^XMD
- +35 KILL XMY,XMSUB,XMTEXT,XMDUZ
- +36 QUIT
- +37 ;ADDED THE DATE INFORMATION
- End DoDot:5
- +38 IF '$DATA(CHECK)
- SET $PIECE(^SD(403.5,D0,0),"^",10)=DT
- +39 if $DATA(CHECK)
- QUIT
- +40 USE IO
- +41 WRITE @IOF
- FOR L=1:1:7
- WRITE !
- +42 SET PNAME=$$NAMEFMT^XLFNAME(PN,"G","")
- +43 WRITE !?20,PNAME
- +44 ; SD*654 fix incomplete addr
- DO ADDR
- +45 IF TIME'=""
- WRITE !!?45,TIME
- +46 IF LAB'=""
- WRITE !,?45,LAB
- End DoDot:4
- End DoDot:3
- +47 DO ^%ZISC
- End DoDot:2
- End DoDot:1
- +48 KILL DPTR,DEVSB,DEVSB1,DIQ,DEVSB1,DA,DA1,DR
- QUIT KILL DEV,PRT,ADTA,D0,DFN,DIC,DIR,DIRUT,DTA,I,L,PN,POP,Y,ZDIV,ZEDT,ZPR,ZSDT,FAST,TIME,ACC,TYPE,PTN,CRP,STATE,PNAME
- +1 KILL LINE,LETTER,MESSAGE,TEST,CLINIC,DA,DATE,DEV1,DEVSB,DOD,FAIL,PROV,TEAM,X,DPT,LAB,SDRR,VA,LAB,DPT,SDRR,VA
- +2 DO KVAR^VADPT
- +3 QUIT
- +4 ;
- KXREF ; SD*579 - If entry does not exist, kill all the x-refs.
- +1 SET STR="BCDE"
- +2 FOR I=1:1:$LENGTH(STR)
- Begin DoDot:1
- +3 SET X=$EXTRACT(STR,I,I)
- +4 SET N3=0
- FOR
- SET N3=$ORDER(^SD(403.5,X,N3))
- if N3'>0
- QUIT
- Begin DoDot:2
- +5 SET N4=0
- FOR
- SET N4=$ORDER(^SD(403.5,X,N3,N4))
- if N4'>0
- QUIT
- Begin DoDot:3
- +6 IF N4=D0
- KILL ^SD(403.5,X,N3,N4)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +7 KILL I,STR,X,N3,N4
- +8 QUIT
- +9 ;
- ADDR ; SD*654 Patient address
- +1 ; Change state to abbr.
- +2 NEW SDRRIENS,SDRRX
- +3 IF $DATA(VAPA(5))
- SET SDRRIENS=+VAPA(5)_","
- SET SDRRX=$$GET1^DIQ(5,SDRRIENS,1)
- SET $PIECE(VAPA(5),U,2)=SDRRX
- +4 IF $DATA(VAPA(17))
- SET SDRRIENS=+VAPA(17)_","
- SET SDRRX=$$GET1^DIQ(5,SDRRIENS,1)
- SET $PIECE(VAPA(17),U,2)=SDRRX
- +5 KILL SDRRIENS,SDRRX
- +6 ;
- +7 NEW SDRRACT1,SDRRACT2,LL
- +8 ; Check Confidential Address Indicator (0=Inactive,1=Active)
- +9 SET SDRRACT1=VAPA(12)
- SET SDRRACT2=$PIECE($GET(VAPA(22,2)),U,3)
- +10 ; If Confidential address is not active, print regular address
- +11 IF ($GET(SDRRACT1)=0)!($GET(SDRRACT2)'="Y")
- Begin DoDot:1
- +12 FOR LL=1:1:3
- if VAPA(LL)]""
- WRITE !,?20,VAPA(LL)
- +13 ; If country is blank, display as USA
- +14 IF (VAPA(25)="")!($PIECE(VAPA(25),U,2)="UNITED STATES")
- Begin DoDot:2
- +15 ; Display city, state, zip
- +16 WRITE !?20,VAPA(4)_" "_$PIECE(VAPA(5),U,2)_" "_$PIECE(VAPA(11),U,2)
- End DoDot:2
- +17 IF '$TEST
- Begin DoDot:2
- +18 ; Display city, province, postal code
- +19 WRITE !?20,VAPA(4)_" "_VAPA(23)_" "_VAPA(24)
- End DoDot:2
- +20 ; Display country
- +21 if ($PIECE(VAPA(25),U,2)'="UNITED STATES")
- WRITE !,?20,$PIECE(VAPA(25),U,2)
- End DoDot:1
- +22 ; If Confidential address is active, print confidential address
- +23 IF $GET(SDRRACT1)=1
- IF $GET(SDRRACT2)="Y"
- Begin DoDot:1
- +24 ;*685
- FOR LL=13:1:15
- if VAPA(LL)]""
- WRITE !,?20,VAPA(LL)
- +25 IF (VAPA(28)="")!($PIECE(VAPA(28),"^",2)="UNITED STATES")
- Begin DoDot:2
- +26 WRITE !,?20,VAPA(16)_" "_$PIECE(VAPA(17),U,2)_" "_$PIECE(VAPA(18),U,2)
- End DoDot:2
- +27 IF '$TEST
- Begin DoDot:2
- +28 WRITE !,?20,VAPA(27)_" "_VAPA(16)_" "_VAPA(26)
- End DoDot:2
- +29 IF ($PIECE(VAPA(28),"^",2)'="UNITED STATES")
- WRITE !?20,$PIECE(VAPA(28),U,2)
- End DoDot:1
- +30 QUIT
