PSALFM ;BIR/LTL-Controlled Connection by FSN Match ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
;
D DT^DICRW
START ;compiles data for edit
EXPL W !,"I'll loop through the FSNs in your DRUG file.",!,"If I find a match in the ITEM MASTER file, I'll let you know.",!
N D0,D1,DA,DIC,DIE,DIR,DIRUT,DIW,DIWF,DIWL,DIWR,DIWT,DLAYGO,DR,DTOUT,DUOUT,PSA,PSAD,PSADD,PSAF,PSAFSN,PSAIT,PSAOUT,X,Y S (PSA,PSAD)=0
LOOP F S PSAD=$O(^PSDRUG(PSAD)) G:'PSAD!($D(PSAOUT)) END I $P($G(^PSDRUG(PSAD,0)),U,6)]"",'$O(^PSDRUG(PSAD,441,0)),'$D(^PSDRUG(PSAD,"I")) D G:$G(PSAOUT) END
.I $Y+5>IOSL S DIR(0)="E" D ^DIR K DIR S:'Y PSAOUT=1 W @IOF Q
FORM .S PSAFSN=$P(^PSDRUG(PSAD,0),U,6) W !,PSAFSN D:$O(^PRC(441,"BB",PSAFSN,0))
..N PSADD S PSAIT=$O(^PRC(441,"BB",PSAFSN,"")) D W !,$E($P(^PSDRUG(PSAD,0),U),1,39)
USED ...I $O(^PSDRUG("AB",PSAIT,"")) S PSADD=$O(^PSDRUG("AB",PSAIT,"")) W !,"**"_$P(^PSDRUG(PSADD,0),U)_" is already linked to Item #"_PSAIT_"**"
INAC ...I $E($G(^PRC(441,PSAIT,3)),1)=1 W !,"Sorry, Item #"_PSAIT_" is INACTIVE, can't link.",! S PSADD=""
..I $L($G(^PRC(441,+PSAIT,1,1,0)))<40,'$O(^PRC(441,+PSAIT,1,1)) W ?40,$G(^PRC(441,+PSAIT,1,1,0)),! G SH
..K ^UTILITY($J,"W") S DIWL=40,DIWR=80,DIWF="W"
..F S PSA=$O(^PRC(441,+PSAIT,1,PSA)) Q:'PSA S X=$G(^PRC(441,+PSAIT,1,PSA,0)) D ^DIWP
..D ^DIWW S PSA=0
SH ..D:'$D(PSADD) OFFER
END I '$G(PSAOUT) S DIR(0)="EA",DIR("A")="Done with FSN's. Press <RET> to return to the menu." D ^DIR
QUIT Q
OFFER S DIR(0)="Y",DIR("A")="Do we have a match",DIR("B")="Yes" D ^DIR K DIR S:$D(DIRUT) PSAOUT=1 Q:'Y D
OK S DIE=50,DA=PSAD,DR="441///^S X=PSAIT" D ^DIE W " Linked to Item #"_PSAIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSALFM 1666 printed Dec 13, 2024@01:49:27 Page 2
PSALFM ;BIR/LTL-Controlled Connection by FSN Match ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
+2 ;
+3 DO DT^DICRW
START ;compiles data for edit
EXPL WRITE !,"I'll loop through the FSNs in your DRUG file.",!,"If I find a match in the ITEM MASTER file, I'll let you know.",!
+1 NEW D0,D1,DA,DIC,DIE,DIR,DIRUT,DIW,DIWF,DIWL,DIWR,DIWT,DLAYGO,DR,DTOUT,DUOUT,PSA,PSAD,PSADD,PSAF,PSAFSN,PSAIT,PSAOUT,X,Y
SET (PSA,PSAD)=0
LOOP FOR
SET PSAD=$ORDER(^PSDRUG(PSAD))
if 'PSAD!($DATA(PSAOUT))
GOTO END
IF $PIECE($GET(^PSDRUG(PSAD,0)),U,6)]""
IF '$ORDER(^PSDRUG(PSAD,441,0))
IF '$DATA(^PSDRUG(PSAD,"I"))
Begin DoDot:1
+1 IF $Y+5>IOSL
SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
SET PSAOUT=1
WRITE @IOF
QUIT
FORM SET PSAFSN=$PIECE(^PSDRUG(PSAD,0),U,6)
WRITE !,PSAFSN
if $ORDER(^PRC(441,"BB",PSAFSN,0))
Begin DoDot:2
+1 NEW PSADD
SET PSAIT=$ORDER(^PRC(441,"BB",PSAFSN,""))
Begin DoDot:3
USED IF $ORDER(^PSDRUG("AB",PSAIT,""))
SET PSADD=$ORDER(^PSDRUG("AB",PSAIT,""))
WRITE !,"**"_$PIECE(^PSDRUG(PSADD,0),U)_" is already linked to Item #"_PSAIT_"**"
INAC IF $EXTRACT($GET(^PRC(441,PSAIT,3)),1)=1
WRITE !,"Sorry, Item #"_PSAIT_" is INACTIVE, can't link.",!
SET PSADD=""
End DoDot:3
WRITE !,$EXTRACT($PIECE(^PSDRUG(PSAD,0),U),1,39)
+1 IF $LENGTH($GET(^PRC(441,+PSAIT,1,1,0)))<40
IF '$ORDER(^PRC(441,+PSAIT,1,1))
WRITE ?40,$GET(^PRC(441,+PSAIT,1,1,0)),!
GOTO SH
+2 KILL ^UTILITY($JOB,"W")
SET DIWL=40
SET DIWR=80
SET DIWF="W"
+3 FOR
SET PSA=$ORDER(^PRC(441,+PSAIT,1,PSA))
if 'PSA
QUIT
SET X=$GET(^PRC(441,+PSAIT,1,PSA,0))
DO ^DIWP
+4 DO ^DIWW
SET PSA=0
SH if '$DATA(PSADD)
DO OFFER
End DoDot:2
End DoDot:1
if $GET(PSAOUT)
GOTO END
END IF '$GET(PSAOUT)
SET DIR(0)="EA"
SET DIR("A")="Done with FSN's. Press <RET> to return to the menu."
DO ^DIR
QUIT QUIT
OFFER SET DIR(0)="Y"
SET DIR("A")="Do we have a match"
SET DIR("B")="Yes"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
SET PSAOUT=1
if 'Y
QUIT
Begin DoDot:1
End DoDot:1
OK SET DIE=50
SET DA=PSAD
SET DR="441///^S X=PSAIT"
DO ^DIE
WRITE " Linked to Item #"_PSAIT
