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 Dec 13, 2024@01:39:58 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
