source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBAPIPM.m@ 1397

PSBAPIPM ;BIRMINGHAM/EFC-BCMA API TO IPM FOR ORDER RENEWAL ;Mar 2004
 ;;3.0;BAR CODE MED ADMIN;**6,15**;Mar 2004
 ;
 ;
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
 ....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) ;
 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 PSBINDX=10
 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