source: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBML1.m@ 636

PSBML1 ;BIRMINGHAM/VRN-BCMA API TO IPM FOR EXPIRING ONE-TIME ORDERS ;Mar 2004
 ;;3.0;BAR CODE MED ADMIN;**3**;Mar 2004
 ;
 ; Reference/IA
 ; EN^PSJBCMA3/3320
 ; ENE^PSJBCMA4/3416
 ; ENR^PSJBCMA4/3416
 ; ^XUSEC/10076
 ;
EXPIRE ;
 S PSBFLAG=0,(X,Y)=""
 F  S X=$O(^PSB(53.79,"AOIP",PSBREC(0),PSBREC(4),X),-1) Q:X=""  D
 .F  S Y=$O(^PSB(53.79,"AOIP",PSBREC(0),PSBREC(4),X,Y),-1) Q:'Y  D
 ..I $D(^PSB(53.79,Y,.3)),$G(^PSB(53.79,Y,.3,1,0))["Manual" S PSBFLAG=1
 ..D:('PSBFLAG)&($P(^PSB(53.79,Y,0),U,9)="G") ENE^PSJBCMA4(PSBREC(0),PSBREC(1)) S (X,Y)=0
 Q
 ;
COMMENT ;
 S PSBIEN="+1,"_PSBIEN_","
 D VAL^PSBML(53.793,PSBIEN,.01,PSBREC(0))
 S PSBFDA(53.793,PSBIEN,.02)=DUZ
 S PSBFDA(53.793,PSBIEN,.03)=PSBNOW
 D FILEIT^PSBML
 Q
 ;
PRN ;
 S PSBIEN=PSBIEN_","
 D VAL^PSBML(53.79,PSBIEN,.22,PSBREC(0))
 D FILEIT^PSBML
 Q
UPDATE ;
 S PSBIEN=PSBIEN_","
 I "^G^N^H^R^RM^S^C^I^"[U_PSBREC(0)_U D
 .D VAL^PSBML(53.79,PSBIEN,.06,PSBNOW)
 .D VAL^PSBML(53.79,PSBIEN,.07,"`"_DUZ)
 .D VAL^PSBML(53.79,PSBIEN,.09,PSBREC(0))
 .I $D(PSBREC(3)),PSBREC(3)]"" D VAL^PSBML(53.79,PSBIEN,.26,PSBREC(3))
 D:PSBREC(1)]""
 .I (PSBREC(0)="N"),($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G") S PSBREC(1)="Not Given: "_PSBREC(1)
 .I ((PSBREC(0)="N")!(PSBREC(0)="G")),($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM") S PSBREC(1)="Undo Remove: "_PSBREC(1)
 .S:PSBREC(0)="H" PSBREC(1)="Held: "_PSBREC(1)
 .S:PSBREC(0)="R" PSBREC(1)="Refused: "_PSBREC(1)
 .S:PSBREC(0)="RM" PSBREC(1)="Removed: "_PSBREC(1)
 .D VAL^PSBML(53.793,"+2,"_PSBIEN,.01,PSBREC(1))
 .D VAL^PSBML(53.793,"+2,"_PSBIEN,.02,"`"_DUZ)
 .D VAL^PSBML(53.793,"+2,"_PSBIEN,.03,PSBNOW)
 S PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
 I ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM"),((PSBREC(0)="N")!(PSBREC(0)="G")) D
 .I '(($D(^XUSEC("PSB MANAGER",DUZ)))!($$GET1^DIQ(53.79,+PSBIEN,.07,"I")=DUZ)) S RESULTS(0)="-1^Verify PSB MANAGER allocation" Q
 .S PSBXPTCH=1,PSBYY="",PSBGIVEN=0 F  S PSBYY=$O(^PSB(53.79,+PSBIEN,.9,PSBYY),-1) Q:'PSBYY  Q:(+$G(RESULTS(0))<0)  Q:PSBGIVEN  S PSBXDAT=$G(^(PSBYY,0))  D
 ..I PSBXDAT["Set to 'GIVEN'" D
 ...S PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
 ...F PSBYX=(PSBYY-2):-1:0 Q:PSBYX<1  I ^PSB(53.79,+PSBIEN,.9,PSBYX,0)["ACTION DATE/TIME Set to" S PSBXDATE=$P(^PSB(53.79,+PSBIEN,.9,PSBYX,0),"'",2),X=$P(PSBXDATE,"@"),%DT="" D ^%DT S PSBXDATE=Y_"."_$TR($P(PSBXDATE,"@",2),":") Q
 ...S PSBXDT=PSBXDATE F  S PSBXDT=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT)) Q:PSBXDT=""  D  Q:+$G(RESULTS(0))<0
 ....S PSBYZ="" F  S PSBYZ=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT,PSBYZ)) Q:'PSBYZ  I $$GET1^DIQ(53.79,PSBYZ,.09,"I")="G" S RESULTS(0)="-1^Cannot UNDO! Order has GIVEN patch" Q
 ...I '(+$G(RESULTS(0))<0) D  S PSBGIVEN=1
 ....D VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE),VAL^PSBML(53.79,PSBIEN,.07,"`"_$P(PSBXDAT,U,2)),VAL^PSBML(53.79,PSBIEN,.09,"G")
 ..D:('(+$G(RESULTS(0))<0))&('PSBGIVEN)&($G(PSBXPTCH))&(PSBYY'>1)
 ...S PSBXDATE=$P(^PSB(53.79,+PSBIEN,.9,PSBYY,0),"'",2),X=$P(PSBXDATE,"@"),%DT="" D ^%DT S PSBXDATE=Y_"."_$TR($P(PSBXDATE,"@",2),":")
 ...D VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE),VAL^PSBML(53.79,PSBIEN,.07,"`"_$$GET1^DIQ(53.79,+PSBIEN,.07,"I")),VAL^PSBML(53.79,PSBIEN,.09,"G") S PSBGIVEN=1
 ;If set to not given then set dose given to 0
 Q:(+$G(RESULTS(0))<0)
 S:$G(PSBGIVEN) PSBREC(0)="G"
 I PSBREC(0)="N",($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G") D:$D(^PSB(53.79,+PSBIEN,.5,0))
 .S PSBX=0 F  S PSBX=$O(^PSB(53.79,$P(PSBIEN,","),.5,PSBX)) Q:'(+PSBX)  S $P(^PSB(53.79,$P(PSBIEN,","),.5,PSBX,0),"^",3)=0
 I $G(PSBREC(2))]"" D VAL^PSBML(53.79,PSBIEN,.16,PSBREC(2))
 S PSBOLDUZ=$P(^PSB(53.79,+PSBIEN,0),U,7),PSBOLSTS=$P(^PSB(53.79,+PSBIEN,0),U,9)
 I $G(PSBREC(4))]"" D  ; DD/SOL/ADD
 .I PSBREC(0)="G"!(PSBREC(0)="I")!(PSBREC(0)="H")!(PSBREC(0)="R")!(PSBREC(0)="M") D  ; Only apply if given or infusing
 ..K ^PSB(53.79,+PSBIEN,.5),^PSB(53.79,+PSBIEN,.6),^PSB(53.79,+PSBIEN,.7)
 ..F PSBCNT=4:1 Q:'$D(PSBREC(PSBCNT))  D
 ...S Y=$P(PSBREC(PSBCNT),U)
 ...S PSBDD=$S(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
 ...Q:'PSBDD
 ...S PSBIENS="+"_PSBCNT_","_PSBIEN
 ...D VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$P(PSBREC(PSBCNT),U,2))
 ...D VAL^PSBML(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,3))
 ...D VAL^PSBML(PSBDD,PSBIENS,.03,$P(PSBREC(PSBCNT),U,4))
 ...D:Y="DD" VAL^PSBML(PSBDD,PSBIENS,.04,$P(PSBREC(PSBCNT),U,5))
 D FILEIT^PSBML
 ; add audit for change of status
 ; tell pharmacy if change of status on pharmacy generated UID
 I $P($G(RESULTS(0)),U,1)=1 D
 .S PSBUID=$P(^PSB(53.79,+PSBIEN,0),U,10) I PSBUID]"",PSBUID'["WS" D
 ..S PSBON=$P(^PSB(53.79,+PSBIEN,.1),U,1)
 ..S PSBDFN=$P(^PSB(53.79,+PSBIEN,0),U,1)
 ..I PSBREC(0)="N" S PSBREC(0)="" D
 ...M PSBAR=^PSB(53.79,+PSBIEN,.9)
 ...S (PSBDN,X)="" F  S X=$O(PSBAR(X),-1) Q:X=0!(PSBDN=1)  D
 ....I PSBAR(X,0)["ACTION STATUS",PSBAR(X,0)["deleted",PSBAR(X,0)'["GIVEN" D
 .....S PSBTS=$P($P(PSBAR(X,0),"'",2),"'",1)
 .....S PSBREC(0)=$S(PSBTS="HELD":"H",PSBTS="REFUSED":"R",PSBTS="REMOVED":"RM",PSBTS="MISSING":"M",1:""),PSBDN=1
 ..I PSBREC(0)="" D VAL^PSBML(53.79,PSBIEN,.26,"") D CLEAN^DILF,UPDATE^DIE("","PSBFDA","PSBIEN","PSBMSG")
 ..D EN^PSJBCMA3(PSBDFN,+PSBON,PSBUID,PSBREC(0),PSBNOW)
 I ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="N") S PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I") D ENR^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
 I ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G") S PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I") D ENE^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
 Q