- PSBAPIPM ;BIRMINGHAM/EFC-BCMA API TO IPM FOR ORDER RENEWAL ;03/06/16 3:06pm
- ;;3.0;BAR CODE MED ADMIN;**6,15,83**;Mar 2004;Build 89
- ;
- ;*83 - moved DD array from psbrec(10) to psbrec(11)
- ;
- EN(PSBDFN,PSBORDX) ;
- ;
- ; PSBLADT=date/time of the last action
- ; PSBADMDT=scheduled time of the last action
- ; PSBSTUS=last action (given, held, refused, etc.)
- ;
- ;
- S (PSBCNT,PSBFLAG)=0,Y=""
- S PSBSTR=""
- I '$D(^PSB(53.79,"AORDX",PSBDFN,PSBORDX)) Q ""
- F S Y=$O(^PSB(53.79,"AORDX",PSBDFN,PSBORDX,Y),-1) Q:Y="" Q:PSBFLAG=1 D
- .S PSBLADT=$S(Y:Y,1:"")
- .S X="" F S X=$O(^PSB(53.79,"AORDX",PSBDFN,PSBORDX,Y,X),-1) Q:X="" D
- ..S PSBSTUS=$P(^PSB(53.79,X,0),U,9) I PSBSTUS'="N" S PSBFLAG=1
- ..S PSBADMDT=$P(^PSB(53.79,X,.1),U,3)
- ..D:PSBSTUS="N"
- ...S (PSBLADT,PSBSTUS,PSBADMDT)=""
- ...S Z="" F S Z=$O(^PSB(53.79,X,.9,Z),-1) Q:'Z Q:PSBFLAG=1 S PSBDATA=$G(^(Z,0)) D
- ....I (PSBDATA["Set to 'NOT GIVEN'")!(PSBDATA["Set to 'GIVEN'")!(PSBDATA["Set to 'REFUSED'")!(PSBDATA["Set to 'HELD'")!(PSBDATA["Set to 'MISSING DOSE'")!(PSBDATA["Set to 'REMOVED'") S PSBCNT=PSBCNT+1
- ....I (PSBDATA["STATUS 'HELD'")!(PSBDATA["STATUS 'GIVEN'")!(PSBDATA["STATUS 'REFUSED'")!(PSBDATA["STATUS 'MISSING DOSE'")!(PSBDATA["STATUS 'REMOVED'") S PSBCNT=PSBCNT+1
- ....I PSBCNT#2=0,PSBDATA["'REFUSED'" S PSBSTUS="R",PSBADMDT=$P(^PSB(53.79,X,.1),U,3) D LAST
- ....I PSBCNT#2=0,PSBDATA["'HELD'" S PSBSTUS="H",PSBADMDT=$P(^PSB(53.79,X,.1),U,3) D LAST
- ....I PSBCNT#2=0,PSBDATA["'MISSING DOSE'" S PSBSTUS="M",PSBADMDT=$P(^PSB(53.79,X,.1),U,3) D LAST
- ....;this is not a valid status that can exist prior to Undo Give *83
- ....;;I PSBCNT#2=0,PSBDATA["'REMOVED'" S PSBSTUS="RM",PSBADMDT=$P(^PSB(53.79,X,.1),U,3) D LAST
- ....;
- I PSBSTUS'="" S PSBSTR=PSBADMDT_U_PSBLADT_U_PSBSTUS
- Q PSBSTR
- ;
- LAST ;
- S PSBCC=0
- S ZZ="" F S ZZ=$O(^PSB(53.79,X,.3,ZZ),-1) Q:'ZZ Q:PSBFLAG=1 S PSBDATA2=$G(^(ZZ,0)) D
- .S PSBCC=PSBCC+1
- .I PSBCC=2 S PSBLADT=$P(PSBDATA2,U,3),PSBFLAG=1
- Q
- MOB(PSBDFN,PSBCORN) ;
- I '$D(^TMP("PSBMO",$J,PSBDFN,PSBCORN)) S ^TMP("PSB",$J,0)=-1 Q
- M ^TMP("PSB",$J)=^TMP("PSBMO",$J,PSBDFN,PSBCORN)
- K ^TMP("PSB",$J,"PSB")
- Q
- ;
- MOBR(PSBDFN,PSBCORN,PSBORDN) ;
- N PSBREC
- I $G(PSBORDN)="" K ^TMP("PSB",$J) Q
- S PSBDUZ=DUZ,PSBDUZ(2)=DUZ(2),DFN=PSBDFN
- S DUZ=$P(^TMP("PSBMO",$J,PSBDFN,PSBCORN,"PSB"),U,1),DUZ(2)=$P(^TMP("PSBMO",$J,PSBDFN,PSBCORN,"PSB"),U,2),PSBISITE=$P(^TMP("PSBMO",$J,PSBDFN,PSBCORN,"PSB"),U,3)
- D PSJ1^PSBVT(PSBDFN,PSBORDN)
- S PSBREC(0)=PSBDFN
- S PSBREC(1)=PSBONX
- S PSBREC(2)=PSBSCHT
- S PSBREC(4)=PSBOIT
- S PSBREC(5)=$P(^TMP("PSBMO",$J,PSBDFN,PSBCORN,0),U,5)
- S PSBREC(6)=""
- S PSBREC(7)="BCMA/CPRS Interface Entry."
- S PSBREC(8)=PSBISITE
- I PSBONX["U" S PSBREC(9)="UDTAB^",PSBREC(3)="G"
- I PSBONX["V" D
- .I "PCS"'[PSBIVT S PSBREC(9)="IVTAB"_U_$$GETWSID^PSBVDLU2(PSBDFN,PSBORDN),PSBREC(3)="I" Q
- .I PSBIVT["S",PSBISYR=0 S PSBREC(9)="IVTAB"_U_$$GETWSID^PSBVDLU2(PSBDFN,PSBORDN),PSBREC(3)="I" Q
- .I PSBIVT["C",PSBISYR=0 S PSBREC(9)="IVTAB"_U_$$GETWSID^PSBVDLU2(PSBDFN,PSBORDN),PSBREC(3)="I" Q
- .S PSBREC(9)="PBTAB"_U_$$GETWSID^PSBVDLU2(PSBDFN,PSBORDN),PSBREC(3)="G" Q
- S PSBIMV="^"_$P($G(^TMP("PSBMO",$J,PSBDFN,PSBCORN,"PSB")),U,4)
- S PSBREC(10)="" ;reserved now for Removal time *83
- S PSBINDX=11 ;DD's moved to here *83
- S X="" F S X=$O(PSBDDA(X)) Q:X="" S PSBREC(PSBINDX)=$P(PSBDDA(X),U,1,2)_U_$P(PSBDDA(X),U,4)_U_$P(PSBDDA(X),U,4)_U_PSBDOSEF,PSBINDX=PSBINDX+1
- S X="" F S X=$O(PSBADA(X)) Q:X="" S PSBREC(PSBINDX)=PSBADA(X),PSBINDX=PSBINDX+1
- S X="" F S X=$O(PSBSOLA(X)) Q:X="" S PSBREC(PSBINDX)=PSBSOLA(X),PSBINDX=PSBINDX+1
- D RPC^PSBML(.PSB,"+1^MEDPASS"_$G(PSBIMV),.PSBREC)
- S DUZ=PSBDUZ,DUZ(2)=PSBDUZ(2) K PSBDUZ,PSBDUZ(2),^TMP("PSBMO",$J,PSBREC(0),PSBCORN),^TMP("PSB",$J) D CLEAN^PSBVT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBAPIPM 3802 printed Jan 18, 2025@02:41:12 Page 2
- PSBAPIPM ;BIRMINGHAM/EFC-BCMA API TO IPM FOR ORDER RENEWAL ;03/06/16 3:06pm
- +1 ;;3.0;BAR CODE MED ADMIN;**6,15,83**;Mar 2004;Build 89
- +2 ;
- +3 ;*83 - moved DD array from psbrec(10) to psbrec(11)
- +4 ;
- EN(PSBDFN,PSBORDX) ;
- +1 ;
- +2 ; PSBLADT=date/time of the last action
- +3 ; PSBADMDT=scheduled time of the last action
- +4 ; PSBSTUS=last action (given, held, refused, etc.)
- +5 ;
- +6 ;
- +7 SET (PSBCNT,PSBFLAG)=0
- SET Y=""
- +8 SET PSBSTR=""
- +9 IF '$DATA(^PSB(53.79,"AORDX",PSBDFN,PSBORDX))
- QUIT ""
- +10 FOR
- SET Y=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBORDX,Y),-1)
- if Y=""
- QUIT
- if PSBFLAG=1
- QUIT
- Begin DoDot:1
- +11 SET PSBLADT=$SELECT(Y:Y,1:"")
- +12 SET X=""
- FOR
- SET X=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBORDX,Y,X),-1)
- if X=""
- QUIT
- Begin DoDot:2
- +13 SET PSBSTUS=$PIECE(^PSB(53.79,X,0),U,9)
- IF PSBSTUS'="N"
- SET PSBFLAG=1
- +14 SET PSBADMDT=$PIECE(^PSB(53.79,X,.1),U,3)
- +15 if PSBSTUS="N"
- Begin DoDot:3
- +16 SET (PSBLADT,PSBSTUS,PSBADMDT)=""
- +17 SET Z=""
- FOR
- SET Z=$ORDER(^PSB(53.79,X,.9,Z),-1)
- if 'Z
- QUIT
- if PSBFLAG=1
- QUIT
- SET PSBDATA=$GET(^(Z,0))
- Begin DoDot:4
- +18 IF (PSBDATA["Set to 'NOT GIVEN'")!(PSBDATA["Set to 'GIVEN'")!(PSBDATA["Set to 'REFUSED'")!(PSBDATA["Set to 'HELD'")!(PSBDATA["Set to 'MISSING DOSE'")!(PSBDATA["Set to 'REMOVED'")
- SET PSBCNT=PSBCNT+1
- +19 IF (PSBDATA["STATUS 'HELD'")!(PSBDATA["STATUS 'GIVEN'")!(PSBDATA["STATUS 'REFUSED'")!(PSBDATA["STATUS 'MISSING DOSE'")!(PSBDATA["STATUS 'REMOVED'")
- SET PSBCNT=PSBCNT+1
- +20 IF PSBCNT#2=0
- IF PSBDATA["'REFUSED'"
- SET PSBSTUS="R"
- SET PSBADMDT=$PIECE(^PSB(53.79,X,.1),U,3)
- DO LAST
- +21 IF PSBCNT#2=0
- IF PSBDATA["'HELD'"
- SET PSBSTUS="H"
- SET PSBADMDT=$PIECE(^PSB(53.79,X,.1),U,3)
- DO LAST
- +22 IF PSBCNT#2=0
- IF PSBDATA["'MISSING DOSE'"
- SET PSBSTUS="M"
- SET PSBADMDT=$PIECE(^PSB(53.79,X,.1),U,3)
- DO LAST
- +23 ;this is not a valid status that can exist prior to Undo Give *83
- +24 ;;I PSBCNT#2=0,PSBDATA["'REMOVED'" S PSBSTUS="RM",PSBADMDT=$P(^PSB(53.79,X,.1),U,3) D LAST
- +25 ;
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +26 IF PSBSTUS'=""
- SET PSBSTR=PSBADMDT_U_PSBLADT_U_PSBSTUS
- +27 QUIT PSBSTR
- +28 ;
- LAST ;
- +1 SET PSBCC=0
- +2 SET ZZ=""
- FOR
- SET ZZ=$ORDER(^PSB(53.79,X,.3,ZZ),-1)
- if 'ZZ
- QUIT
- if PSBFLAG=1
- QUIT
- SET PSBDATA2=$GET(^(ZZ,0))
- Begin DoDot:1
- +3 SET PSBCC=PSBCC+1
- +4 IF PSBCC=2
- SET PSBLADT=$PIECE(PSBDATA2,U,3)
- SET PSBFLAG=1
- End DoDot:1
- +5 QUIT
- MOB(PSBDFN,PSBCORN) ;
- +1 IF '$DATA(^TMP("PSBMO",$JOB,PSBDFN,PSBCORN))
- SET ^TMP("PSB",$JOB,0)=-1
- QUIT
- +2 MERGE ^TMP("PSB",$JOB)=^TMP("PSBMO",$JOB,PSBDFN,PSBCORN)
- +3 KILL ^TMP("PSB",$JOB,"PSB")
- +4 QUIT
- +5 ;
- MOBR(PSBDFN,PSBCORN,PSBORDN) ;
- +1 NEW PSBREC
- +2 IF $GET(PSBORDN)=""
- KILL ^TMP("PSB",$JOB)
- QUIT
- +3 SET PSBDUZ=DUZ
- SET PSBDUZ(2)=DUZ(2)
- SET DFN=PSBDFN
- +4 SET DUZ=$PIECE(^TMP("PSBMO",$JOB,PSBDFN,PSBCORN,"PSB"),U,1)
- SET DUZ(2)=$PIECE(^TMP("PSBMO",$JOB,PSBDFN,PSBCORN,"PSB"),U,2)
- SET PSBISITE=$PIECE(^TMP("PSBMO",$JOB,PSBDFN,PSBCORN,"PSB"),U,3)
- +5 DO PSJ1^PSBVT(PSBDFN,PSBORDN)
- +6 SET PSBREC(0)=PSBDFN
- +7 SET PSBREC(1)=PSBONX
- +8 SET PSBREC(2)=PSBSCHT
- +9 SET PSBREC(4)=PSBOIT
- +10 SET PSBREC(5)=$PIECE(^TMP("PSBMO",$JOB,PSBDFN,PSBCORN,0),U,5)
- +11 SET PSBREC(6)=""
- +12 SET PSBREC(7)="BCMA/CPRS Interface Entry."
- +13 SET PSBREC(8)=PSBISITE
- +14 IF PSBONX["U"
- SET PSBREC(9)="UDTAB^"
- SET PSBREC(3)="G"
- +15 IF PSBONX["V"
- Begin DoDot:1
- +16 IF "PCS"'[PSBIVT
- SET PSBREC(9)="IVTAB"_U_$$GETWSID^PSBVDLU2(PSBDFN,PSBORDN)
- SET PSBREC(3)="I"
- QUIT
- +17 IF PSBIVT["S"
- IF PSBISYR=0
- SET PSBREC(9)="IVTAB"_U_$$GETWSID^PSBVDLU2(PSBDFN,PSBORDN)
- SET PSBREC(3)="I"
- QUIT
- +18 IF PSBIVT["C"
- IF PSBISYR=0
- SET PSBREC(9)="IVTAB"_U_$$GETWSID^PSBVDLU2(PSBDFN,PSBORDN)
- SET PSBREC(3)="I"
- QUIT
- +19 SET PSBREC(9)="PBTAB"_U_$$GETWSID^PSBVDLU2(PSBDFN,PSBORDN)
- SET PSBREC(3)="G"
- QUIT
- End DoDot:1
- +20 SET PSBIMV="^"_$PIECE($GET(^TMP("PSBMO",$JOB,PSBDFN,PSBCORN,"PSB")),U,4)
- +21 ;reserved now for Removal time *83
- SET PSBREC(10)=""
- +22 ;DD's moved to here *83
- SET PSBINDX=11
- +23 SET X=""
- FOR
- SET X=$ORDER(PSBDDA(X))
- if X=""
- QUIT
- SET PSBREC(PSBINDX)=$PIECE(PSBDDA(X),U,1,2)_U_$PIECE(PSBDDA(X),U,4)_U_$PIECE(PSBDDA(X),U,4)_U_PSBDOSEF
- SET PSBINDX=PSBINDX+1
- +24 SET X=""
- FOR
- SET X=$ORDER(PSBADA(X))
- if X=""
- QUIT
- SET PSBREC(PSBINDX)=PSBADA(X)
- SET PSBINDX=PSBINDX+1
- +25 SET X=""
- FOR
- SET X=$ORDER(PSBSOLA(X))
- if X=""
- QUIT
- SET PSBREC(PSBINDX)=PSBSOLA(X)
- SET PSBINDX=PSBINDX+1
- +26 DO RPC^PSBML(.PSB,"+1^MEDPASS"_$GET(PSBIMV),.PSBREC)
- +27 SET DUZ=PSBDUZ
- SET DUZ(2)=PSBDUZ(2)
- KILL PSBDUZ,PSBDUZ(2),^TMP("PSBMO",$JOB,PSBREC(0),PSBCORN),^TMP("PSB",$JOB)
- DO CLEAN^PSBVT
- +28 QUIT