Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSBAPIPM

PSBAPIPM.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;*83 - moved DD array from psbrec(10) to psbrec(11)
  1. ;
  1. EN(PSBDFN,PSBORDX) ;
  1. ;
  1. ; PSBLADT=date/time of the last action
  1. ; PSBADMDT=scheduled time of the last action
  1. ; PSBSTUS=last action (given, held, refused, etc.)
  1. ;
  1. ;
  1. S (PSBCNT,PSBFLAG)=0,Y=""
  1. S PSBSTR=""
  1. I '$D(^PSB(53.79,"AORDX",PSBDFN,PSBORDX)) Q ""
  1. F S Y=$O(^PSB(53.79,"AORDX",PSBDFN,PSBORDX,Y),-1) Q:Y="" Q:PSBFLAG=1 D
  1. .S PSBLADT=$S(Y:Y,1:"")
  1. .S X="" F S X=$O(^PSB(53.79,"AORDX",PSBDFN,PSBORDX,Y,X),-1) Q:X="" D
  1. ..S PSBSTUS=$P(^PSB(53.79,X,0),U,9) I PSBSTUS'="N" S PSBFLAG=1
  1. ..S PSBADMDT=$P(^PSB(53.79,X,.1),U,3)
  1. ..D:PSBSTUS="N"
  1. ...S (PSBLADT,PSBSTUS,PSBADMDT)=""
  1. ...S Z="" F S Z=$O(^PSB(53.79,X,.9,Z),-1) Q:'Z Q:PSBFLAG=1 S PSBDATA=$G(^(Z,0)) D
  1. ....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
  1. ....I (PSBDATA["STATUS 'HELD'")!(PSBDATA["STATUS 'GIVEN'")!(PSBDATA["STATUS 'REFUSED'")!(PSBDATA["STATUS 'MISSING DOSE'")!(PSBDATA["STATUS 'REMOVED'") S PSBCNT=PSBCNT+1
  1. ....I PSBCNT#2=0,PSBDATA["'REFUSED'" S PSBSTUS="R",PSBADMDT=$P(^PSB(53.79,X,.1),U,3) D LAST
  1. ....I PSBCNT#2=0,PSBDATA["'HELD'" S PSBSTUS="H",PSBADMDT=$P(^PSB(53.79,X,.1),U,3) D LAST
  1. ....I PSBCNT#2=0,PSBDATA["'MISSING DOSE'" S PSBSTUS="M",PSBADMDT=$P(^PSB(53.79,X,.1),U,3) D LAST
  1. ....;this is not a valid status that can exist prior to Undo Give *83
  1. ....;;I PSBCNT#2=0,PSBDATA["'REMOVED'" S PSBSTUS="RM",PSBADMDT=$P(^PSB(53.79,X,.1),U,3) D LAST
  1. ....;
  1. I PSBSTUS'="" S PSBSTR=PSBADMDT_U_PSBLADT_U_PSBSTUS
  1. Q PSBSTR
  1. ;
  1. LAST ;
  1. S PSBCC=0
  1. S ZZ="" F S ZZ=$O(^PSB(53.79,X,.3,ZZ),-1) Q:'ZZ Q:PSBFLAG=1 S PSBDATA2=$G(^(ZZ,0)) D
  1. .S PSBCC=PSBCC+1
  1. .I PSBCC=2 S PSBLADT=$P(PSBDATA2,U,3),PSBFLAG=1
  1. Q
  1. MOB(PSBDFN,PSBCORN) ;
  1. I '$D(^TMP("PSBMO",$J,PSBDFN,PSBCORN)) S ^TMP("PSB",$J,0)=-1 Q
  1. M ^TMP("PSB",$J)=^TMP("PSBMO",$J,PSBDFN,PSBCORN)
  1. K ^TMP("PSB",$J,"PSB")
  1. Q
  1. ;
  1. MOBR(PSBDFN,PSBCORN,PSBORDN) ;
  1. N PSBREC
  1. I $G(PSBORDN)="" K ^TMP("PSB",$J) Q
  1. S PSBDUZ=DUZ,PSBDUZ(2)=DUZ(2),DFN=PSBDFN
  1. 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)
  1. D PSJ1^PSBVT(PSBDFN,PSBORDN)
  1. S PSBREC(0)=PSBDFN
  1. S PSBREC(1)=PSBONX
  1. S PSBREC(2)=PSBSCHT
  1. S PSBREC(4)=PSBOIT
  1. S PSBREC(5)=$P(^TMP("PSBMO",$J,PSBDFN,PSBCORN,0),U,5)
  1. S PSBREC(6)=""
  1. S PSBREC(7)="BCMA/CPRS Interface Entry."
  1. S PSBREC(8)=PSBISITE
  1. I PSBONX["U" S PSBREC(9)="UDTAB^",PSBREC(3)="G"
  1. I PSBONX["V" D
  1. .I "PCS"'[PSBIVT S PSBREC(9)="IVTAB"_U_$$GETWSID^PSBVDLU2(PSBDFN,PSBORDN),PSBREC(3)="I" Q
  1. .I PSBIVT["S",PSBISYR=0 S PSBREC(9)="IVTAB"_U_$$GETWSID^PSBVDLU2(PSBDFN,PSBORDN),PSBREC(3)="I" Q
  1. .I PSBIVT["C",PSBISYR=0 S PSBREC(9)="IVTAB"_U_$$GETWSID^PSBVDLU2(PSBDFN,PSBORDN),PSBREC(3)="I" Q
  1. .S PSBREC(9)="PBTAB"_U_$$GETWSID^PSBVDLU2(PSBDFN,PSBORDN),PSBREC(3)="G" Q
  1. S PSBIMV="^"_$P($G(^TMP("PSBMO",$J,PSBDFN,PSBCORN,"PSB")),U,4)
  1. S PSBREC(10)="" ;reserved now for Removal time *83
  1. S PSBINDX=11 ;DD's moved to here *83
  1. 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
  1. S X="" F S X=$O(PSBADA(X)) Q:X="" S PSBREC(PSBINDX)=PSBADA(X),PSBINDX=PSBINDX+1
  1. S X="" F S X=$O(PSBSOLA(X)) Q:X="" S PSBREC(PSBINDX)=PSBSOLA(X),PSBINDX=PSBINDX+1
  1. D RPC^PSBML(.PSB,"+1^MEDPASS"_$G(PSBIMV),.PSBREC)
  1. S DUZ=PSBDUZ,DUZ(2)=PSBDUZ(2) K PSBDUZ,PSBDUZ(2),^TMP("PSBMO",$J,PSBREC(0),PSBCORN),^TMP("PSB",$J) D CLEAN^PSBVT
  1. Q