- 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 Mar 13, 2025@20:45:45 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
