PSSCPRS1 ;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
;
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 ; I/P to O/P Transfer Rules - Numeric Dosages
;
FR541 I '$P($G(^PSDRUG(+PSDD,"I")),"^")!($P($G(^("I")),"^")'<DT),(PSUSE["O") S RESULT(0)=1,RESULT(1)=PSDD_"^"_PSDOS,RESULT(2)="FR541" Q
;
;
FR542 S PSCORR=$P(PSNODE8,U,5) 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),PDOS=$G(^PSDRUG(PSCORR,"DOS")),PSSTR=$P(PDOS,U),PSUNT=$P(PDOS,U,2)
..I PSDOS'="",($P(PSDOS1,U,2)=PSDOS),($P(PSNODE2,U,3)["O")&($P(PSDOS1,U,3)["O") D
...I $P(X,U,4)=$P(PSDOSN,U,2),$P(X,"^")=$P(X1,"^") S RESULT(0)=1,RESULT(1)=PSCORR_"^"_PSDOS,RESULT(2)="FR542" Q
Q:RESULT(0)=1
;
;
FR543 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)["O")&($P(BB,U,3)["O") 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)="FR543",FLAG=0 Q
;
;
FR544 S PSCORR=$P(PSNODE8,U,5) 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(X,"^")=$P(X1,"^") S RESULT(0)=1,RESULT(1)=PSDD
Q:RESULT(0)=1
;
;
FR545 S RESULT(0)=-1,RESULT(2)="All Numeric Dosage Rules failed!"
Q
;
;
NNSI ; I/P to O/P Transfer Rules- NON-NUMERIC Single Ingredient
;
FR551 I '$P($G(^PSDRUG(+PSDD,"I")),"^")!($P($G(^("I")),"^")'<DT),(PSUSE["U")&(PSUSE["O") S RESULT(0)=1,RESULT(1)=PSDD_"^"_PSDOS_"^"_PSOI_"^"_PSDUD Q
;
;
FR552 I PSUSE'["U",(PSUSE'["O") S PSCORR=$P(PSNODE8,U,5) 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(X,"^")=$P(X1,"^") S RESULT(0)=1,RESULT(1)=PSCORR_"^"_PSDOS_"^"_PSOI_"^"_PSDUD
;
;
FR553 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
Q:RESULT(0)=1
;
FR554 S RESULT(0)=-1
Q
;
NNMI ; I/P to O/P Transfer Rules- Multi-Ingredient
;
FR561 I '$P($G(^PSDRUG(+PSDD,"I")),"^")!($P($G(^("I")),"^")'<DT),(PSUSE["U")&(PSUSE["O") S RESULT(0)=1,RESULT(1)=PSDD_"^"_PSDOS_"^"_PSOI_"^"_PSDUD Q
;
;
FR562 I PSUSE'["U",(PSUSE'["O") S PSCORR=$P(PSNODE8,U,5) 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(X,"^")=$P(X1,"^") S RESULT(0)=1,RESULT(1)=PSCORR_"^"_PSOD_"^"_PSSOP_"^"_PSDUD
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[HPSSCPRS1 3819 printed Sep 23, 2025@20:06:14 Page 2
PSSCPRS1 ;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
+8 ;
+9 if +PSDUD>0
GOTO ND
+10 IF 'PSSND1!('PSSND3)
SET RESULT(0)=-1
SET RESULT(2)="Problem in ND node!"
QUIT
+11 SET X=$$DFSU^PSNAPIS(PSSND1,PSSND3)
IF $PIECE(X,U,4)=""
DO NNSI
QUIT
+12 IF $PIECE(X,U)'=""
DO NNMI
+13 QUIT
ND ; I/P to O/P Transfer Rules - Numeric Dosages
+1 ;
FR541 IF '$PIECE($GET(^PSDRUG(+PSDD,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
IF (PSUSE["O")
SET RESULT(0)=1
SET RESULT(1)=PSDD_"^"_PSDOS
SET RESULT(2)="FR541"
QUIT
+1 ;
+2 ;
FR542 SET PSCORR=$PIECE(PSNODE8,U,5)
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)
SET PDOS=$GET(^PSDRUG(PSCORR,"DOS"))
SET PSSTR=$PIECE(PDOS,U)
SET PSUNT=$PIECE(PDOS,U,2)
+3 IF PSDOS'=""
IF ($PIECE(PSDOS1,U,2)=PSDOS)
IF ($PIECE(PSNODE2,U,3)["O")&($PIECE(PSDOS1,U,3)["O")
Begin DoDot:3
+4 IF $PIECE(X,U,4)=$PIECE(PSDOSN,U,2)
IF $PIECE(X,"^")=$PIECE(X1,"^")
SET RESULT(0)=1
SET RESULT(1)=PSCORR_"^"_PSDOS
SET RESULT(2)="FR542"
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+5 if RESULT(0)=1
QUIT
+6 ;
+7 ;
FR543 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)&($PIECE(PSNODE2,U,3)["O")&($PIECE(BB,U,3)["O")
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)="FR543"
SET FLAG=0
QUIT
+9 ;
+10 ;
FR544 SET PSCORR=$PIECE(PSNODE8,U,5)
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(X,"^")=$PIECE(X1,"^")
SET RESULT(0)=1
SET RESULT(1)=PSDD
End DoDot:1
+2 if RESULT(0)=1
QUIT
+3 ;
+4 ;
FR545 SET RESULT(0)=-1
SET RESULT(2)="All Numeric Dosage Rules failed!"
+1 QUIT
+2 ;
+3 ;
NNSI ; I/P to O/P Transfer Rules- NON-NUMERIC Single Ingredient
+1 ;
FR551 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
QUIT
+1 ;
+2 ;
FR552 IF PSUSE'["U"
IF (PSUSE'["O")
SET PSCORR=$PIECE(PSNODE8,U,5)
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(X,"^")=$PIECE(X1,"^")
SET RESULT(0)=1
SET RESULT(1)=PSCORR_"^"_PSDOS_"^"_PSOI_"^"_PSDUD
End DoDot:2
End DoDot:1
if RESULT(0)=1
QUIT
+4 ;
+5 ;
FR553 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)
+3 SET PSNDSTR=$PIECE(X,U,3)
SET PSNDUN=$PIECE(X,U,4)
+4 IF (PSSTR'="")&(PSUNT'="")
IF (PSSTR=PSNDSTR)&(PSUNT=PSNDUN)
SET RESULT(0)=1
SET RESULT(1)=AA_"^"_PSDOS_"^"_PSOI_"^"_PSDUD
End DoDot:1
+5 if RESULT(0)=1
QUIT
+6 ;
FR554 SET RESULT(0)=-1
+1 QUIT
+2 ;
NNMI ; I/P to O/P Transfer Rules- Multi-Ingredient
+1 ;
FR561 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
QUIT
+1 ;
+2 ;
FR562 IF PSUSE'["U"
IF (PSUSE'["O")
SET PSCORR=$PIECE(PSNODE8,U,5)
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(X,"^")=$PIECE(X1,"^")
SET RESULT(0)=1
SET RESULT(1)=PSCORR_"^"_PSOD_"^"_PSSOP_"^"_PSDUD
End DoDot:1
+2 QUIT
CP ;
+1 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)
+2 SET PSDOSN=$GET(^PSDRUG(PSDD,"DOS"))
SET X1=$$CPRS^PSNAPIS(PSSND1,PSSND3)
+3 QUIT
