- APCHS7O ; IHS/CMI/LAB - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
- ;;2.0;IHS PCC SUITE;**5**;MAY 14, 2009
- ;NOTE: VERSION OF APCHS7 TO BE USED WITH UNPATCHED 5.0.6 OR EARLIER
- ;
- MEDS ; ************** CURRENT MEDICATIONS * 9000010.14 ********
- S APCHSALL=0 G CONT
- MEDSALL ; **************** ALL MEDICATIONS * 9000010.14 **********
- S APCHSALL=1
- ;
- CONT ; <SETUP>
- ;Q:'$D(^AUPNVMED("AC",APCHSPAT))
- X APCHSCKP Q:$D(APCHSQIT) I 'APCHSNPG W ! X APCHSBRK
- ; <BUILD>
- K ^TMP($J,"APCHSMTB"),^TMP($J,"APCHSMTP")
- S APCHSIVD=0 F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVMED("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) S APCHSMX=0 F APCHSQ=0:0 S APCHSMX=$O(^AUPNVMED("AA",APCHSPAT,APCHSIVD,APCHSMX)) Q:APCHSMX="" D MEDBLD
- ; <DISPLAY>
- S APCHSIVD=0 F APCHSQ=0:0 S APCHSIVD=$O(^TMP($J,"APCHSMTP",APCHSIVD)) Q:'APCHSIVD D MEDDSP
- ; <CLEANUP>
- MEDX K APCHSIVD,APCHSMX,APCHSMFX,APCHSQTY,APCHSIG,APCHSSGY,APCHSEXP,APCHSMTS,APCHSMED,APCHSDTM,APCHSDAT,APCHSDYS,APCHSN,APCHSDC,APCHSVDF,APCHSP
- K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,APCHSRX,APCHSDRG,APCHSCRN,APCHSREF,APCHSRFL,APCHSALL,APCHSTXT
- K ^TMP($J,"APCHSMTB"),^TMP($J,"APCHSMTP")
- K X1,X2,X,Y
- Q
- MEDBLD ;
- ;
- ;BUILD ARRAY OF MEDICATIONS
- ;APCHSDC=DATE DISCONTINUED,DYS=DAYS PRESCRIBED,SIG=DIRECTIONS
- ;VDF=VISIT FILE DATE
- Q:'$D(^AUPNVMED(APCHSMX,0))
- S APCHSN=^AUPNVMED(APCHSMX,0)
- Q:'$D(^PSDRUG($P(APCHSN,U,1)))
- S APCHSDTM=-APCHSIVD\1+9999999
- S APCHSDC=$P(APCHSN,U,8),APCHSDYS=$P(APCHSN,U,7),APCHSMFX=+APCHSN
- I $D(^TMP($J,"APCHSMTB",APCHSMFX)),^TMP($J,"APCHSMTB",APCHSMFX)="" Q
- S:APCHSDYS="" APCHSDYS=30
- ;SCREENS OUT MEDS NOT CURRENT; APCHSALL FORCES INCLUSION OF ALL MEDS
- I 'APCHSALL S X1=DT,X2=APCHSDTM D ^%DTC Q:X>60&(X>(2*APCHSDYS))
- S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
- Q
- MEDDSP ;
- ;
- ;DISPLAY MEDICATION
- ;APCHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
- S APCHSMX=^TMP($J,"APCHSMTP",APCHSIVD)
- S APCHSN=^AUPNVMED(APCHSMX,0)
- S APCHSRX=$S($D(^PSRX("APCC",APCHSMX)):$O(^(APCHSMX,0)),1:0)
- S APCHSCRN=$S(+APCHSRX:$D(^PS(55,APCHSPAT,"P","CP",APCHSRX)),1:0)
- S (Y,APCHSDTM)=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
- S APCHSDC=$P(APCHSN,U,8),APCHSDYS=$P(APCHSN,U,7),APCHSQTY=$P(APCHSN,U,6),APCHSIG=$P(APCHSN,U,5),APCHSVDF=$P(APCHSN,U,3),APCHSMFX=+APCHSN
- S:APCHSDYS="" APCHSDYS=30
- S X1=DT,X2=APCHSDTM D ^%DTC ;Q:X>60&(X>(2*APCHSDYS))
- S APCHSEXP=""
- I X>APCHSDYS S X1=APCHSDTM,X2=APCHSDYS D C^%DTC S Y=X X APCHSCVD S APCHSEXP="-- Ran out "_Y
- S APCHSMED=$P(^PSDRUG(APCHSMFX,0),U,1)
- I APCHSDC S Y=APCHSDC X APCHSCVD S APCHSEXP="-- D/C "_Y
- D SIG S APCHSIG=APCHSSGY
- D REF I APCHSREF S APCHSIG=APCHSIG_" "_APCHSREF_$S(APCHSREF=1:" refill",1:" refills")_" left."
- D SITE ;I APCHSITE]"" S APCHSIG=APCHSIG_" ["_APCHSITE_"]"
- X APCHSCKP Q:$D(APCHSQIT)
- W APCHSDAT,?10,$S(APCHSCRN:"(C)",1:""),?14,APCHSMED," #",APCHSQTY," (",APCHSDYS," days) ",APCHSEXP,!
- I APCHSITE]"" W ?14,"Dispensed at: ",APCHSITE,!
- X APCHSCKP Q:$D(APCHSQIT)
- S APCHSICL=14,APCHSNRQ="",APCHSTXT=APCHSIG D PRTTXT^APCHSUTL K APCHSICL,APCHSNRQ,APCHSP
- Q
- ;
- SIG ;
- ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
- S APCHSSGY="" F APCHSP=1:1:$L(APCHSIG," ") S X=$P(APCHSIG," ",APCHSP) I X]"" D
- . S Y=$O(^DIC(51,"B",X,0)) I Y>0 S X=$P(^DIC(51,Y,0),"^",2) I $D(^(9)) S Y=$P(APCHSIG," ",APCHSP-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(^(9),"^",1)
- . S APCHSSGY=APCHSSGY_X_" "
- Q
- ;
- REF ;EP
- ;DETERMINE THE NUMBER OF REFILLS REMAINING
- I 'APCHSRX S APCHSREF=0 Q
- S APCHSRFL=$P(^PSRX(APCHSRX,0),U,9) S APCHSREF=0 F S APCHSREF=$O(^PSRX(APCHSRX,1,APCHSREF)) Q:'APCHSREF S APCHSRFL=APCHSRFL-1
- S APCHSREF=APCHSRFL
- Q
- ;
- SITE ;
- S APCHSITE=""
- I $D(^AUPNVSIT(APCHSVDF,21))#2 S APCHSITE=$P(^(21),U) Q
- Q:$P(^AUPNVSIT(APCHSVDF,0),U,6)=""
- I $P(^AUPNVSIT(APCHSVDF,0),U,6)'=DUZ(2) S APCHSITE=$E($P(^DIC(4,$P(^AUPNVSIT(APCHSVDF,0),U,6),0),U),1,30)
- Q
- APCHS7O ; IHS/CMI/LAB - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
- +1 ;;2.0;IHS PCC SUITE;**5**;MAY 14, 2009
- +2 ;NOTE: VERSION OF APCHS7 TO BE USED WITH UNPATCHED 5.0.6 OR EARLIER
- +3 ;
- MEDS ; ************** CURRENT MEDICATIONS * 9000010.14 ********
- +1 SET APCHSALL=0
- GOTO CONT
- MEDSALL ; **************** ALL MEDICATIONS * 9000010.14 **********
- +1 SET APCHSALL=1
- +2 ;
- CONT ; <SETUP>
- +1 ;Q:'$D(^AUPNVMED("AC",APCHSPAT))
- +2 XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- IF 'APCHSNPG
- WRITE !
- XECUTE APCHSBRK
- +3 ; <BUILD>
- +4 KILL ^TMP($JOB,"APCHSMTB"),^TMP($JOB,"APCHSMTP")
- +5 SET APCHSIVD=0
- FOR APCHSQ=0:0
- SET APCHSIVD=$ORDER(^AUPNVMED("AA",APCHSPAT,APCHSIVD))
- IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
- QUIT
- SET APCHSMX=0
- FOR APCHSQ=0:0
- SET APCHSMX=$ORDER(^AUPNVMED("AA",APCHSPAT,APCHSIVD,APCHSMX))
- IF APCHSMX=""
- QUIT
- DO MEDBLD
- +6 ; <DISPLAY>
- +7 SET APCHSIVD=0
- FOR APCHSQ=0:0
- SET APCHSIVD=$ORDER(^TMP($JOB,"APCHSMTP",APCHSIVD))
- IF 'APCHSIVD
- QUIT
- DO MEDDSP
- +8 ; <CLEANUP>
- MEDX KILL APCHSIVD,APCHSMX,APCHSMFX,APCHSQTY,APCHSIG,APCHSSGY,APCHSEXP,APCHSMTS,APCHSMED,APCHSDTM,APCHSDAT,APCHSDYS,APCHSN,APCHSDC,APCHSVDF,APCHSP
- +1 KILL APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,APCHSRX,APCHSDRG,APCHSCRN,APCHSREF,APCHSRFL,APCHSALL,APCHSTXT
- +2 KILL ^TMP($JOB,"APCHSMTB"),^TMP($JOB,"APCHSMTP")
- +3 KILL X1,X2,X,Y
- +4 QUIT
- MEDBLD ;
- +1 ;
- +2 ;BUILD ARRAY OF MEDICATIONS
- +3 ;APCHSDC=DATE DISCONTINUED,DYS=DAYS PRESCRIBED,SIG=DIRECTIONS
- +4 ;VDF=VISIT FILE DATE
- +5 IF '$DATA(^AUPNVMED(APCHSMX,0))
- QUIT
- +6 SET APCHSN=^AUPNVMED(APCHSMX,0)
- +7 IF '$DATA(^PSDRUG($PIECE(APCHSN,U,1)))
- QUIT
- +8 SET APCHSDTM=-APCHSIVD\1+9999999
- +9 SET APCHSDC=$PIECE(APCHSN,U,8)
- SET APCHSDYS=$PIECE(APCHSN,U,7)
- SET APCHSMFX=+APCHSN
- +10 IF $DATA(^TMP($JOB,"APCHSMTB",APCHSMFX))
- IF ^TMP($JOB,"APCHSMTB",APCHSMFX)=""
- QUIT
- +11 IF APCHSDYS=""
- SET APCHSDYS=30
- +12 ;SCREENS OUT MEDS NOT CURRENT; APCHSALL FORCES INCLUSION OF ALL MEDS
- +13 IF 'APCHSALL
- SET X1=DT
- SET X2=APCHSDTM
- DO ^%DTC
- IF X>60&(X>(2*APCHSDYS))
- QUIT
- +14 SET ^TMP($JOB,"APCHSMTB",APCHSMFX)=APCHSDC
- SET ^TMP($JOB,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
- +15 QUIT
- MEDDSP ;
- +1 ;
- +2 ;DISPLAY MEDICATION
- +3 ;APCHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
- +4 SET APCHSMX=^TMP($JOB,"APCHSMTP",APCHSIVD)
- +5 SET APCHSN=^AUPNVMED(APCHSMX,0)
- +6 SET APCHSRX=$SELECT($DATA(^PSRX("APCC",APCHSMX)):$ORDER(^(APCHSMX,0)),1:0)
- +7 SET APCHSCRN=$SELECT(+APCHSRX:$DATA(^PS(55,APCHSPAT,"P","CP",APCHSRX)),1:0)
- +8 SET (Y,APCHSDTM)=-APCHSIVD\1+9999999
- XECUTE APCHSCVD
- SET APCHSDAT=Y
- +9 SET APCHSDC=$PIECE(APCHSN,U,8)
- SET APCHSDYS=$PIECE(APCHSN,U,7)
- SET APCHSQTY=$PIECE(APCHSN,U,6)
- SET APCHSIG=$PIECE(APCHSN,U,5)
- SET APCHSVDF=$PIECE(APCHSN,U,3)
- SET APCHSMFX=+APCHSN
- +10 IF APCHSDYS=""
- SET APCHSDYS=30
- +11 ;Q:X>60&(X>(2*APCHSDYS))
- SET X1=DT
- SET X2=APCHSDTM
- DO ^%DTC
- +12 SET APCHSEXP=""
- +13 IF X>APCHSDYS
- SET X1=APCHSDTM
- SET X2=APCHSDYS
- DO C^%DTC
- SET Y=X
- XECUTE APCHSCVD
- SET APCHSEXP="-- Ran out "_Y
- +14 SET APCHSMED=$PIECE(^PSDRUG(APCHSMFX,0),U,1)
- +15 IF APCHSDC
- SET Y=APCHSDC
- XECUTE APCHSCVD
- SET APCHSEXP="-- D/C "_Y
- +16 DO SIG
- SET APCHSIG=APCHSSGY
- +17 DO REF
- IF APCHSREF
- SET APCHSIG=APCHSIG_" "_APCHSREF_$SELECT(APCHSREF=1:" refill",1:" refills")_" left."
- +18 ;I APCHSITE]"" S APCHSIG=APCHSIG_" ["_APCHSITE_"]"
- DO SITE
- +19 XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- +20 WRITE APCHSDAT,?10,$SELECT(APCHSCRN:"(C)",1:""),?14,APCHSMED," #",APCHSQTY," (",APCHSDYS," days) ",APCHSEXP,!
- +21 IF APCHSITE]""
- WRITE ?14,"Dispensed at: ",APCHSITE,!
- +22 XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- +23 SET APCHSICL=14
- SET APCHSNRQ=""
- SET APCHSTXT=APCHSIG
- DO PRTTXT^APCHSUTL
- KILL APCHSICL,APCHSNRQ,APCHSP
- +24 QUIT
- +25 ;
- SIG ;
- +1 ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
- +2 SET APCHSSGY=""
- FOR APCHSP=1:1:$LENGTH(APCHSIG," ")
- SET X=$PIECE(APCHSIG," ",APCHSP)
- IF X]""
- Begin DoDot:1
- +3 SET Y=$ORDER(^DIC(51,"B",X,0))
- IF Y>0
- SET X=$PIECE(^DIC(51,Y,0),"^",2)
- IF $DATA(^(9))
- SET Y=$PIECE(APCHSIG," ",APCHSP-1)
- SET Y=$EXTRACT(Y,$LENGTH(Y))
- IF Y>1
- SET X=$PIECE(^(9),"^",1)
- +4 SET APCHSSGY=APCHSSGY_X_" "
- End DoDot:1
- +5 QUIT
- +6 ;
- REF ;EP
- +1 ;DETERMINE THE NUMBER OF REFILLS REMAINING
- +2 IF 'APCHSRX
- SET APCHSREF=0
- QUIT
- +3 SET APCHSRFL=$PIECE(^PSRX(APCHSRX,0),U,9)
- SET APCHSREF=0
- FOR
- SET APCHSREF=$ORDER(^PSRX(APCHSRX,1,APCHSREF))
- IF 'APCHSREF
- QUIT
- SET APCHSRFL=APCHSRFL-1
- +4 SET APCHSREF=APCHSRFL
- +5 QUIT
- +6 ;
- SITE ;
- +1 SET APCHSITE=""
- +2 IF $DATA(^AUPNVSIT(APCHSVDF,21))#2
- SET APCHSITE=$PIECE(^(21),U)
- QUIT
- +3 IF $PIECE(^AUPNVSIT(APCHSVDF,0),U,6)=""
- QUIT
- +4 IF $PIECE(^AUPNVSIT(APCHSVDF,0),U,6)'=DUZ(2)
- SET APCHSITE=$EXTRACT($PIECE(^DIC(4,$PIECE(^AUPNVSIT(APCHSVDF,0),U,6),0),U),1,30)
- +5 QUIT
