- SDRRTSK1 ;10N20/MAH;Recall Reminder-Clinic Print Task; 09/20/2004
- ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
- ;;This routine is called from SDRR TASK JOB CARD
- ;;and will be called if PARAM IS cards
- 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
- ....S DTA=$G(^SD(403.5,D0,0))
- ....S TIME=""
- ....I $P(^SD(403.5,D0,0),"^",9)>45 S TIME=$P(^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:$$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 !
- ....W !?20,$P(PN,",",2)," ",$P(PN,",")
- ....I $P(VAPA(1),U)'="" W !?20,$P(VAPA(1),U)
- ....I $P(VAPA(2),U)'="" W !?20,$P(VAPA(2),U)
- ....I $P(VAPA(3),U)'="" W !?20,$P(VAPA(3),U)
- ....W !?20,$P(VAPA(4),U),", "_STATE_" ",$P(VAPA(6),U)
- ....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
- 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
- SDRRTSK1 ;10N20/MAH;Recall Reminder-Clinic Print Task; 09/20/2004
- +1 ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
- +2 ;;This routine is called from SDRR TASK JOB CARD
- +3 ;;and will be called if PARAM IS cards
- 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 SET DTA=$GET(^SD(403.5,D0,0))
- +16 SET TIME=""
- +17 IF $PIECE(^SD(403.5,D0,0),"^",9)>45
- SET TIME=$PIECE(^SD(403.5,D0,0),"^",9)
- SET TIME="**"_TIME_"**"
- +18 SET LAB=$SELECT($PIECE($GET(^SD(403.5,D0,0)),"^",8)="f":"**FL",$PIECE(^SD(403.5,D0,0),"^",8)="n":"**NFL",1:"")
- +19 SET DFN=+DTA
- +20 IF $PIECE(DTA,U,6)<ZSDT!($PIECE(DTA,U,6)>ZEDT)
- QUIT
- +21 IF $$TESTPAT^VADPT(DFN)
- QUIT
- +22 DO ADD^VADPT
- DO DEM^VADPT
- +23 SET STATE=$PIECE(VAPA(5),"^",1)
- SET STATE=$$GET1^DIQ(5,STATE_",",1)
- +24 SET PN=$PIECE(VADM(1),U)
- +25 IF $GET(VADM(6),U)'=""
- QUIT
- +26 NEW CHECK
- +27 IF $$BADADR^DGUTL3(DFN)
- SET CHECK=1
- SET XMSUB="Bad Address for Recall Reminder Patient"
- SET XMTEXT="SDRR("
- Begin DoDot:5
- +28 SET XMY("G.SDRR BAD ADDRESS")=""
- SET XMDUZ=.5
- +29 SET SDRR(1)="Bad Address- card will not be printed for:"_" "_PN_" "_VA("BID")
- +30 DO ^XMD
- +31 KILL XMY,XMSUB,XMTEXT,XMDUZ
- +32 QUIT
- +33 ;ADDED THE DATE INFORMATION
- End DoDot:5
- +34 IF '$DATA(CHECK)
- SET $PIECE(^SD(403.5,D0,0),"^",10)=DT
- +35 IF $DATA(CHECK)
- QUIT
- +36 USE IO
- +37 WRITE @IOF
- FOR L=1:1:7
- WRITE !
- +38 WRITE !?20,$PIECE(PN,",",2)," ",$PIECE(PN,",")
- +39 IF $PIECE(VAPA(1),U)'=""
- WRITE !?20,$PIECE(VAPA(1),U)
- +40 IF $PIECE(VAPA(2),U)'=""
- WRITE !?20,$PIECE(VAPA(2),U)
- +41 IF $PIECE(VAPA(3),U)'=""
- WRITE !?20,$PIECE(VAPA(3),U)
- +42 WRITE !?20,$PIECE(VAPA(4),U),", "_STATE_" ",$PIECE(VAPA(6),U)
- +43 IF TIME'=""
- WRITE !!?45,TIME
- +44 IF LAB'=""
- WRITE !,?45,LAB
- End DoDot:4
- End DoDot:3
- +45 DO ^%ZISC
- End DoDot:2
- End DoDot:1
- +46 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
- +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
