- PSSCPRS ;BIR/ASJ-API for CPRS ;09/07/00
- ;;1.0;PHARMACY DATA MANAGEMENT;**38**;9/30/97
- ;Reference to $$CPRS^PSNAPIS supported by DBIA 2531
- ;
- ; PSDD -Dispense Drug, PSOI-Orderable Item, PSPK-Package
- ; PSDOS-Dosage, PSDUD-Dispense Units per Dosage
- ;RESULT(1)=Dispense Drug^Dosage^Orderable Item^Dispense Units per Dosage
- ;RESULT(2)=ERROR DESCRIPTION
- CPRS(PSSAR) ;
- N AA,BB,FLAG,PDOS,PDS,POSDOS,PSCORR,PSDOS1,PSDPD,PSDUPD,PSLI,PSMARK,PSND,PSNDSTR,PSNDUN,PSNODE2,PSOD,PSSND1,PSSND3,PSSNDF,PSSOP,PSSTR,PSUNT,PSNODE,PSUSE,PSDD,PSOI,PSDOS,PSDUD,PSPK,PSNODE8,X
- K RESULTS S RESULT(0)=-1,(FLAG,PSMARK)=0,U="^"
- S PSDD=$G(PSSAR("DRUG")),PSOI=$G(PSSAR("ITEM")),PSPK=$G(PSSAR("PACK"))
- S PSDOS=$G(PSSAR("DOSAGE")),PSDUD=$G(PSSAR("DUPD"))
- I 'PSDD!('PSOI) Q
- S PSNODE=$G(^PSDRUG(+PSDD,0)),PSUSE=$P($G(^(2)),U,3),PSNODE8=$G(^(8))
- S PSSNDF=$G(^PSDRUG(+PSDD,"ND")),PSSND1=$P(PSSNDF,U),PSSND3=$P(PSSNDF,U,3)
- G:PSPK="I" ^PSSCPRS1 G:+PSDUD>0 ND
- I 'PSSND1!('PSSND3) S RESULT(0)=-1,RESULT(2)="Problem in ND node!" Q
- S X=$$DFSU^PSNAPIS(PSSND1,PSSND3) I $P(X,U,4)="" D NNSI Q
- I $P(X,U)'="" D NNMI
- Q
- ND ; O/P to I/P Transfer Rules - Numeric Dosages
- ;
- FR571 I '$P($G(^PSDRUG(+PSDD,"I")),"^")!($P($G(^("I")),"^")'<DT),(PSUSE["U") S RESULT(0)=1,RESULT(1)=PSDD_"^"_PSDOS,RESULT(2)="FR571" Q
- ;
- FR572 S PSCORR=$P(PSNODE8,U,6) I PSCORR I '$P($G(^PSDRUG(PSCORR,"I")),"^")!($P($G(^("I")),"^")'<DT) S PSNODE2=$G(^PSDRUG(PSCORR,2)) D CP D
- .F PDS=0:0 S PDS=$O(^PSDRUG(PSCORR,"DOS1",PDS)) Q:'PDS D
- ..S PSDOS1=^PSDRUG(PSCORR,"DOS1",PDS,0)
- ..I PSDOS'="",$P(PSDOS1,U,2)=PSDOS,($P(PSNODE2,U,3)["U")&($P(PSDOS1,U,3)["I") D
- ...I $P(X,U,4)=$P(PSDOSN,U,2),$P(X1,U)=$P(X,U) S RESULT(0)=1,RESULT(1)=PSCORR_"^"_PSDOS,RESULT(2)="FR572" Q
- Q:RESULT(0)=1
- ;
- FR573 S AA=0 F S AA=$O(^PSDRUG("ASP",+PSOI,AA)) Q:'AA D
- .I $D(^PSDRUG(AA,"DOS1",0)) F PDS=0:0 S PDS=$O(^PSDRUG(AA,"DOS1",PDS)) Q:'PDS D
- ..S BB=^PSDRUG(AA,"DOS1",PDS,0),PSNODE2=$G(^PSDRUG(AA,2))
- ..I PSDOS'="",$P(BB,U,2)=PSDOS,($P(PSNODE2,U,3)["U")&($P(BB,U,3)["I") S FLAG=1,PSLI(AA)=""
- ;
- I FLAG S AA=0 F S AA=$O(PSLI(AA)) Q:'AA F PDS=0:0 S PDS=$O(^PSDRUG(AA,"DOS1",PDS)) Q:'PDS D
- .S POSDOS=^PSDRUG(AA,"DOS1",PDS,0) S PSDPD=+$P(POSDOS,U)
- .I '$D(PSDUPD)!(PSDPD<PSDUPD) S PSDUPD=PSDPD
- I FLAG S RESULT(0)=1,RESULT(1)=AA_"^"_$P(POSDOS,U,2),RESULT(2)="FR573",FLAG=0 Q
- ;
- FR574 S PSCORR=$P(PSNODE8,U,6) I PSCORR I '$P($G(^PSDRUG(PSCORR,"I")),"^")!($P($G(^("I")),"^")'<DT) D CP D
- .I $P(X,U,4)=$P(PSDOSN,U,2),$P(X1,U)=$P(X,U) S RESULT(0)=1,RESULT(1)=PSDD,RESULT(2)="FR574"
- Q:RESULT(0)=1
- ;
- FR575 S RESULT(0)=-1,RESULT(2)="All Numeric Dosage Rules failed!"
- Q
- ;
- NNSI ; O/P to I/P Transfer Rules- NON-NUMERIC Single Ingredient
- FR581 I '$P($G(^PSDRUG(+PSDD,"I")),"^")!($P($G(^("I")),"^")'<DT),(PSUSE["U")&(PSUSE["O") S RESULT(0)=1,RESULT(1)=PSDD_"^"_PSDOS_"^"_PSOI_"^"_PSDUD,RESULT(2)="FR581" Q
- ;
- FR582 I (PSUSE'["U")&(PSUSE'["O") S PSCORR=$P(PSNODE8,U,6) I PSCORR I '$P($G(^PSDRUG(PSCORR,"I")),"^")!($P($G(^("I")),"^")'<DT) D CP D Q:RESULT(0)=1
- .S PDOS=$G(^PSDRUG(PSCORR,"DOS")),PSSTR=$P(PDOS,U),PSUNT=$P(PDOS,U,2)
- .I (PSSTR'="")&(PSUNT'=""),(PSSTR=PSNDSTR&(PSUNT=PSNDUN)) D
- ..I $P(X,U,4)=$P(PSDOSN,U,2),$P(X1,U)=$P(X,U) S RESULT(0)=1,RESULT(1)=PSCORR_"^"_PSDOS_"^"_PSOI_"^"_PSDUD,RESULT(2)="FR582"
- ;
- FR583 S AA=0 F S AA=$O(^PSDRUG("ASP",+PSOI,AA)) Q:'AA D
- .S PSSTR=$P($G(^PSDRUG(AA,"DOS")),U),PSUNT=$P($G(^("DOS")),U,2)
- .S X=$$CPRS^PSNAPIS(PSSND1,PSSND3) S PSNDSTR=$P(X,U,3),PSNDUN=$P(X,U,4)
- .I (PSSTR'="")&(PSUNT'=""),(PSSTR=PSNDSTR)&(PSUNT=PSNDUN) S RESULT(0)=1,RESULT(1)=AA_"^"_PSDOS_"^"_PSOI_"^"_PSDUD,RESULT(2)="FR583"
- Q:RESULT(0)=1
- FR584 S RESULT(0)=-1
- Q
- ;
- NNMI ; O/P to I/P Transfer Rules- Multi-Ingredient
- ;
- FR591 I '$P($G(^PSDRUG(+PSDD,"I")),"^")!($P($G(^("I")),"^")'<DT),(PSUSE["U")&(PSUSE["O") S RESULT(0)=1,RESULT(1)=PSDD_"^"_PSDOS_"^"_PSOI_"^"_PSDUD,RESULT(2)="FR591" Q
- ;
- FR592 I (PSUSE'["U")&(PSUSE'["O") S PSCORR=$P(PSNODE8,U,6) I PSCORR I '$P($G(^PSDRUG(PSCORR,"I")),"^")!($P($G(^("I")),"^")'<DT) D CP D
- .I $P(X,U,4)=$P(PSDOSN,U,2),$P(X1,U)=$P(X,U) S RESULT(0)=1,RESULT(1)=PSCORR_"^"_PSOD_"^"_PSSOP_"^"_PSDUD,RESULT(2)="FR592"
- Q
- ;
- CP S PSND=$G(^PSDRUG(PSCORR,"ND")) S X=$$CPRS^PSNAPIS($P(PSND,"^"),$P(PSND,"^",3)),PSNDSTR=$P(X,U,3),PSNDUN=$P(X,U,4)
- S PSDOSN=$G(^PSDRUG(PSDD,"DOS")),X1=$$CPRS^PSNAPIS(PSSND1,PSSND3)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSCPRS 4371 printed Feb 18, 2025@23:56:35 Page 2
- PSSCPRS ;BIR/ASJ-API for CPRS ;09/07/00
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**38**;9/30/97
- +2 ;Reference to $$CPRS^PSNAPIS supported by DBIA 2531
- +3 ;
- +4 ; PSDD -Dispense Drug, PSOI-Orderable Item, PSPK-Package
- +5 ; PSDOS-Dosage, PSDUD-Dispense Units per Dosage
- +6 ;RESULT(1)=Dispense Drug^Dosage^Orderable Item^Dispense Units per Dosage
- +7 ;RESULT(2)=ERROR DESCRIPTION
- CPRS(PSSAR) ;
- +1 NEW AA,BB,FLAG,PDOS,PDS,POSDOS,PSCORR,PSDOS1,PSDPD,PSDUPD,PSLI,PSMARK,PSND,PSNDSTR,PSNDUN,PSNODE2,PSOD,PSSND1,PSSND3,PSSNDF,PSSOP,PSSTR,PSUNT,PSNODE,PSUSE,PSDD,PSOI,PSDOS,PSDUD,PSPK,PSNODE8,X
- +2 KILL RESULTS
- SET RESULT(0)=-1
- SET (FLAG,PSMARK)=0
- SET U="^"
- +3 SET PSDD=$GET(PSSAR("DRUG"))
- SET PSOI=$GET(PSSAR("ITEM"))
- SET PSPK=$GET(PSSAR("PACK"))
- +4 SET PSDOS=$GET(PSSAR("DOSAGE"))
- SET PSDUD=$GET(PSSAR("DUPD"))
- +5 IF 'PSDD!('PSOI)
- QUIT
- +6 SET PSNODE=$GET(^PSDRUG(+PSDD,0))
- SET PSUSE=$PIECE($GET(^(2)),U,3)
- SET PSNODE8=$GET(^(8))
- +7 SET PSSNDF=$GET(^PSDRUG(+PSDD,"ND"))
- SET PSSND1=$PIECE(PSSNDF,U)
- SET PSSND3=$PIECE(PSSNDF,U,3)
- +8 if PSPK="I"
- GOTO ^PSSCPRS1
- if +PSDUD>0
- GOTO ND
- +9 IF 'PSSND1!('PSSND3)
- SET RESULT(0)=-1
- SET RESULT(2)="Problem in ND node!"
- QUIT
- +10 SET X=$$DFSU^PSNAPIS(PSSND1,PSSND3)
- IF $PIECE(X,U,4)=""
- DO NNSI
- QUIT
- +11 IF $PIECE(X,U)'=""
- DO NNMI
- +12 QUIT
- ND ; O/P to I/P Transfer Rules - Numeric Dosages
- +1 ;
- FR571 IF '$PIECE($GET(^PSDRUG(+PSDD,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
- IF (PSUSE["U")
- SET RESULT(0)=1
- SET RESULT(1)=PSDD_"^"_PSDOS
- SET RESULT(2)="FR571"
- QUIT
- +1 ;
- FR572 SET PSCORR=$PIECE(PSNODE8,U,6)
- IF PSCORR
- IF '$PIECE($GET(^PSDRUG(PSCORR,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
- SET PSNODE2=$GET(^PSDRUG(PSCORR,2))
- DO CP
- Begin DoDot:1
- +1 FOR PDS=0:0
- SET PDS=$ORDER(^PSDRUG(PSCORR,"DOS1",PDS))
- if 'PDS
- QUIT
- Begin DoDot:2
- +2 SET PSDOS1=^PSDRUG(PSCORR,"DOS1",PDS,0)
- +3 IF PSDOS'=""
- IF $PIECE(PSDOS1,U,2)=PSDOS
- IF ($PIECE(PSNODE2,U,3)["U")&($PIECE(PSDOS1,U,3)["I")
- Begin DoDot:3
- +4 IF $PIECE(X,U,4)=$PIECE(PSDOSN,U,2)
- IF $PIECE(X1,U)=$PIECE(X,U)
- SET RESULT(0)=1
- SET RESULT(1)=PSCORR_"^"_PSDOS
- SET RESULT(2)="FR572"
- QUIT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +5 if RESULT(0)=1
- QUIT
- +6 ;
- FR573 SET AA=0
- FOR
- SET AA=$ORDER(^PSDRUG("ASP",+PSOI,AA))
- if 'AA
- QUIT
- Begin DoDot:1
- +1 IF $DATA(^PSDRUG(AA,"DOS1",0))
- FOR PDS=0:0
- SET PDS=$ORDER(^PSDRUG(AA,"DOS1",PDS))
- if 'PDS
- QUIT
- Begin DoDot:2
- +2 SET BB=^PSDRUG(AA,"DOS1",PDS,0)
- SET PSNODE2=$GET(^PSDRUG(AA,2))
- +3 IF PSDOS'=""
- IF $PIECE(BB,U,2)=PSDOS
- IF ($PIECE(PSNODE2,U,3)["U")&($PIECE(BB,U,3)["I")
- SET FLAG=1
- SET PSLI(AA)=""
- End DoDot:2
- End DoDot:1
- +4 ;
- +5 IF FLAG
- SET AA=0
- FOR
- SET AA=$ORDER(PSLI(AA))
- if 'AA
- QUIT
- FOR PDS=0:0
- SET PDS=$ORDER(^PSDRUG(AA,"DOS1",PDS))
- if 'PDS
- QUIT
- Begin DoDot:1
- +6 SET POSDOS=^PSDRUG(AA,"DOS1",PDS,0)
- SET PSDPD=+$PIECE(POSDOS,U)
- +7 IF '$DATA(PSDUPD)!(PSDPD<PSDUPD)
- SET PSDUPD=PSDPD
- End DoDot:1
- +8 IF FLAG
- SET RESULT(0)=1
- SET RESULT(1)=AA_"^"_$PIECE(POSDOS,U,2)
- SET RESULT(2)="FR573"
- SET FLAG=0
- QUIT
- +9 ;
- FR574 SET PSCORR=$PIECE(PSNODE8,U,6)
- IF PSCORR
- IF '$PIECE($GET(^PSDRUG(PSCORR,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
- DO CP
- Begin DoDot:1
- +1 IF $PIECE(X,U,4)=$PIECE(PSDOSN,U,2)
- IF $PIECE(X1,U)=$PIECE(X,U)
- SET RESULT(0)=1
- SET RESULT(1)=PSDD
- SET RESULT(2)="FR574"
- End DoDot:1
- +2 if RESULT(0)=1
- QUIT
- +3 ;
- FR575 SET RESULT(0)=-1
- SET RESULT(2)="All Numeric Dosage Rules failed!"
- +1 QUIT
- +2 ;
- NNSI ; O/P to I/P Transfer Rules- NON-NUMERIC Single Ingredient
- FR581 IF '$PIECE($GET(^PSDRUG(+PSDD,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
- IF (PSUSE["U")&(PSUSE["O")
- SET RESULT(0)=1
- SET RESULT(1)=PSDD_"^"_PSDOS_"^"_PSOI_"^"_PSDUD
- SET RESULT(2)="FR581"
- QUIT
- +1 ;
- FR582 IF (PSUSE'["U")&(PSUSE'["O")
- SET PSCORR=$PIECE(PSNODE8,U,6)
- IF PSCORR
- IF '$PIECE($GET(^PSDRUG(PSCORR,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
- DO CP
- Begin DoDot:1
- +1 SET PDOS=$GET(^PSDRUG(PSCORR,"DOS"))
- SET PSSTR=$PIECE(PDOS,U)
- SET PSUNT=$PIECE(PDOS,U,2)
- +2 IF (PSSTR'="")&(PSUNT'="")
- IF (PSSTR=PSNDSTR&(PSUNT=PSNDUN))
- Begin DoDot:2
- +3 IF $PIECE(X,U,4)=$PIECE(PSDOSN,U,2)
- IF $PIECE(X1,U)=$PIECE(X,U)
- SET RESULT(0)=1
- SET RESULT(1)=PSCORR_"^"_PSDOS_"^"_PSOI_"^"_PSDUD
- SET RESULT(2)="FR582"
- End DoDot:2
- End DoDot:1
- if RESULT(0)=1
- QUIT
- +4 ;
- FR583 SET AA=0
- FOR
- SET AA=$ORDER(^PSDRUG("ASP",+PSOI,AA))
- if 'AA
- QUIT
- Begin DoDot:1
- +1 SET PSSTR=$PIECE($GET(^PSDRUG(AA,"DOS")),U)
- SET PSUNT=$PIECE($GET(^("DOS")),U,2)
- +2 SET X=$$CPRS^PSNAPIS(PSSND1,PSSND3)
- SET PSNDSTR=$PIECE(X,U,3)
- SET PSNDUN=$PIECE(X,U,4)
- +3 IF (PSSTR'="")&(PSUNT'="")
- IF (PSSTR=PSNDSTR)&(PSUNT=PSNDUN)
- SET RESULT(0)=1
- SET RESULT(1)=AA_"^"_PSDOS_"^"_PSOI_"^"_PSDUD
- SET RESULT(2)="FR583"
- End DoDot:1
- +4 if RESULT(0)=1
- QUIT
- FR584 SET RESULT(0)=-1
- +1 QUIT
- +2 ;
- NNMI ; O/P to I/P Transfer Rules- Multi-Ingredient
- +1 ;
- FR591 IF '$PIECE($GET(^PSDRUG(+PSDD,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
- IF (PSUSE["U")&(PSUSE["O")
- SET RESULT(0)=1
- SET RESULT(1)=PSDD_"^"_PSDOS_"^"_PSOI_"^"_PSDUD
- SET RESULT(2)="FR591"
- QUIT
- +1 ;
- FR592 IF (PSUSE'["U")&(PSUSE'["O")
- SET PSCORR=$PIECE(PSNODE8,U,6)
- IF PSCORR
- IF '$PIECE($GET(^PSDRUG(PSCORR,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
- DO CP
- Begin DoDot:1
- +1 IF $PIECE(X,U,4)=$PIECE(PSDOSN,U,2)
- IF $PIECE(X1,U)=$PIECE(X,U)
- SET RESULT(0)=1
- SET RESULT(1)=PSCORR_"^"_PSOD_"^"_PSSOP_"^"_PSDUD
- SET RESULT(2)="FR592"
- End DoDot:1
- +2 QUIT
- +3 ;
- CP SET PSND=$GET(^PSDRUG(PSCORR,"ND"))
- SET X=$$CPRS^PSNAPIS($PIECE(PSND,"^"),$PIECE(PSND,"^",3))
- SET PSNDSTR=$PIECE(X,U,3)
- SET PSNDUN=$PIECE(X,U,4)
- +1 SET PSDOSN=$GET(^PSDRUG(PSDD,"DOS"))
- SET X1=$$CPRS^PSNAPIS(PSSND1,PSSND3)
- +2 QUIT