PSBPXLP ;BIR/RMS - BCMA2PCE FOR IMMUNIZATIONS, TASKED ; 6/23/09 4:16pm
;;3.0;BAR CODE MED ADMIN;**47,76,142**;Mar 2004;Build 12
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; File 50.7/2180
; File 9999999.14/1990
; ^AUPNVIMM("AA"/2313
;
;Class III to Class I Conversion Project
;Contributions of George Holcomb (West Palm Beach) and
;Geri Wittenberg (Hines, now at North Chicago) are acknowledged.
;--------------------------------------------------------------
;
TASK ;
Q ;p142 bcma2pce sunset
I $D(ZTQUEUED) G TASK2
N %DT,DTOUT,X,X1,X2,Y,PSBDTB,PSBUDT
S X1=DT,X2=-1 D C^%DTC S PSBDTB=X\1
W !,"Immunizations Documentation by BCMA",!
S %DT="AEP",%DT("A")="Select START DATE: "
S %DT("B")=$$FMTE^XLFDT(X),%DT(0)=-PSBDTB
D ^%DT
Q:Y'>0
S PSBUDT=$$FMADD^XLFDT(Y,1)\1
D TASK2
Q
;
TASK2 N PAT,REC,STARTDT,X,X1,X2
N PSB507,PSBDFN,PSBIMM,PSBDX,PSBDT,PSBDATE,PSBWHO,PSBLOC
S X1=$G(PSBUDT,DT),X2=-1 D C^%DTC S STARTDT=X-.000001
S PAT=0 F S PAT=$O(^PSB(53.79,"AADT",PAT)) Q:'PAT D
.S PSBDATE=STARTDT F S PSBDATE=$O(^PSB(53.79,"AADT",PAT,PSBDATE)) Q:'PSBDATE!(PSBDATE'<DT) D
..S REC=0 F S REC=$O(^PSB(53.79,"AADT",PAT,PSBDATE,REC)) Q:'REC D
...Q:$P($G(^PSB(53.79,REC,0)),"^",9)'="G"
...S PSB507=$P(^PSB(53.79,REC,0),"^",8) Q:'+PSB507
...S PSBIMM=+$G(^PS(50.7,PSB507,"IMM")) Q:'+PSBIMM
...S PSBDFN=$P(^PSB(53.79,REC,0),"^")
...S PSBDT=$P(^PSB(53.79,REC,0),"^",6)\1
...S PSBWHO=$P(^PSB(53.79,REC,0),"^",7)
...S PSBLOC=$P(^PSB(53.79,REC,0),"^",2)
...W:$E(IOST)="C" !,$E($$GET1^DIQ(2,PSBDFN,.01),1,20),?25,$E($$GET1^DIQ(9999999.14,PSBIMM,.01),1,12)," (",$$FMTE^XLFDT(PSBDT,2),")",?50,$$GET1^DIQ(200,PSBWHO,.01) ; FOR TROUBLESHOOTING ASSISTANCE
...I $D(^AUPNVIMM("AA",PSBDFN,PSBIMM,9999999-PSBDT)) D Q ;->
....I $E(IOST)="C" W !,"Result: Immunization already on file."
...D BCMA2PCE^PSBPXFL(PSBDFN,PSBIMM,"",PSBDT,PSBWHO,PSBLOC)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBPXLP 1987 printed Oct 16, 2024@17:41:57 Page 2
PSBPXLP ;BIR/RMS - BCMA2PCE FOR IMMUNIZATIONS, TASKED ; 6/23/09 4:16pm
+1 ;;3.0;BAR CODE MED ADMIN;**47,76,142**;Mar 2004;Build 12
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; File 50.7/2180
+6 ; File 9999999.14/1990
+7 ; ^AUPNVIMM("AA"/2313
+8 ;
+9 ;Class III to Class I Conversion Project
+10 ;Contributions of George Holcomb (West Palm Beach) and
+11 ;Geri Wittenberg (Hines, now at North Chicago) are acknowledged.
+12 ;--------------------------------------------------------------
+13 ;
TASK ;
+1 ;p142 bcma2pce sunset
QUIT
+2 IF $DATA(ZTQUEUED)
GOTO TASK2
+3 NEW %DT,DTOUT,X,X1,X2,Y,PSBDTB,PSBUDT
+4 SET X1=DT
SET X2=-1
DO C^%DTC
SET PSBDTB=X\1
+5 WRITE !,"Immunizations Documentation by BCMA",!
+6 SET %DT="AEP"
SET %DT("A")="Select START DATE: "
+7 SET %DT("B")=$$FMTE^XLFDT(X)
SET %DT(0)=-PSBDTB
+8 DO ^%DT
+9 if Y'>0
QUIT
+10 SET PSBUDT=$$FMADD^XLFDT(Y,1)\1
+11 DO TASK2
+12 QUIT
+13 ;
TASK2 NEW PAT,REC,STARTDT,X,X1,X2
+1 NEW PSB507,PSBDFN,PSBIMM,PSBDX,PSBDT,PSBDATE,PSBWHO,PSBLOC
+2 SET X1=$GET(PSBUDT,DT)
SET X2=-1
DO C^%DTC
SET STARTDT=X-.000001
+3 SET PAT=0
FOR
SET PAT=$ORDER(^PSB(53.79,"AADT",PAT))
if 'PAT
QUIT
Begin DoDot:1
+4 SET PSBDATE=STARTDT
FOR
SET PSBDATE=$ORDER(^PSB(53.79,"AADT",PAT,PSBDATE))
if 'PSBDATE!(PSBDATE'<DT)
QUIT
Begin DoDot:2
+5 SET REC=0
FOR
SET REC=$ORDER(^PSB(53.79,"AADT",PAT,PSBDATE,REC))
if 'REC
QUIT
Begin DoDot:3
+6 if $PIECE($GET(^PSB(53.79,REC,0)),"^",9)'="G"
QUIT
+7 SET PSB507=$PIECE(^PSB(53.79,REC,0),"^",8)
if '+PSB507
QUIT
+8 SET PSBIMM=+$GET(^PS(50.7,PSB507,"IMM"))
if '+PSBIMM
QUIT
+9 SET PSBDFN=$PIECE(^PSB(53.79,REC,0),"^")
+10 SET PSBDT=$PIECE(^PSB(53.79,REC,0),"^",6)\1
+11 SET PSBWHO=$PIECE(^PSB(53.79,REC,0),"^",7)
+12 SET PSBLOC=$PIECE(^PSB(53.79,REC,0),"^",2)
+13 ; FOR TROUBLESHOOTING ASSISTANCE
if $EXTRACT(IOST)="C"
WRITE !,$EXTRACT($$GET1^DIQ(2,PSBDFN,.01),1,20),?25,$EXTRACT($$GET1^DIQ(9999999.14,PSBIMM,.01),1,12)," (",$$FMTE^XLFDT(PSBDT,2),")",?50,$$GET1^DIQ(200,PSBWHO,.01)
+14 ;->
IF $DATA(^AUPNVIMM("AA",PSBDFN,PSBIMM,9999999-PSBDT))
Begin DoDot:4
+15 IF $EXTRACT(IOST)="C"
WRITE !,"Result: Immunization already on file."
End DoDot:4
QUIT
+16 DO BCMA2PCE^PSBPXFL(PSBDFN,PSBIMM,"",PSBDT,PSBWHO,PSBLOC)
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT
