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 Sep 23, 2025@20:06:13 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
