NURSAFLL ;HIRMFO/RM,MD,FT-LOOKUP FOR FILE 211.4 ;10/10/96 13:03
;;4.0;NURSING SERVICE;;Apr 25, 1997
EN1 ; RETURNS Y=-1 IF NO SELECTION
K DTOUT,DUOUT S NUREXIT=0,NUR=$O(^DIC(40.9,"C","NU","")) I NUR'>0 S Y=-1 W !,$C(7),"Need to add Nursing to the LOCATION TYPE (#40.9) File" G Q
Q:'$D(DIC(0))!'($D(DIC)#2)
I $S('($D(X)#2):1,X="":1,1:0)&(DIC(0)'["A") S Y=-1 Q
K Y,NURDICR I $D(DICR) S %Y="NURDICR(",%X="DICR(" D %XY^%RCR S NURDICR=DICR K DICR
S:DIC(0)'["A" NURTMX=X S NURDIC=DIC I $D(DIC)\10 S NUR="" F NUR(0)=0:0 S NUR=$O(DIC(NUR)) Q:NUR="" S NURDIC(NUR)=DIC(NUR)
READ ;
S X=$$EN8^NURSAFU0(),NURMDSW=$S(X="Y":1,1:0)
I $$SITE^VASITE()'>0 W *7,!?5,"Cannot identify your Primary Station Number.",!?5,"Please contact your ADPAC or IRM Support Person.",! S Y=-1 Q
K X,DIC S:NURDIC(0)'["A" X=NURTMX S DIC=NURDIC I $D(NURDIC)\10 S NUR="" F NUR(0)=0:0 S NUR=$O(NURDIC(NUR)) Q:NUR="" S DIC(NUR)=NURDIC(NUR)
I DIC(0)["A" W !,$S('$D(DIC("A")):"Select NURSING UNIT NAME: ",1:DIC("A"))_$S('$D(DIC("B")):"",1:$S(DIC("B")?1"NUR ".E:$P(DIC("B"),"NUR ",2),1:DIC("B"))_"// ")
I R X:DTIME S:X="^" DUOUT=1 S:'$T X="^",DTOUT=1 S:X=""&$T&$D(DIC("B")) X=DIC("B") S NURTMX=X I "^"[X S Y=-1 G Q
I X?1"?".E D HELP G READ:DIC(0)["A",Q
S DIC(0)="EI",DIC="^NURSF(211.4,",X=$S(X=" "!(X?1"NUR ".E):X,1:"NUR "_X) D ^DIC
I +Y'>0 D:NURDIC(0)["M"&(NURTMX'?1"NUR ".E) MULT I +Y'>0,$S(NURDIC(0)'["L":1,'$D(DLAYGO):0,DLAYGO=211.4:0,1:1) W:NURDIC(0)["Q" $C(7)," ??" G READ:NURDIC(0)["A",Q
G:+Y>0 Q K NURLAY S:$D(DLAYGO) NURLAY=DLAYGO
K DIC S X=NURTMX,X=$S(X=" "!(X?1"NUR ".E):X,X?1"""".E1"""":"""NUR "_$E(X,2,$L(X)),1:"NUR "_X),DLAYGO=44,DIC="^SC(",DIC(0)="EL",DIC("W")="",DIC("S")="I NUR=$P(^(0),U,22)"
S DIC("DR")="2///^S X=""Z"";2.1///^S X=""NURSING"";S:'$G(NURMDSW) Y=""@1"";3;S Y=""@2"";@1;3///^S X=""`""_+$$SITE^VASITE();@2"
D ^DIC K DIC("S"),DIC("DR"),DLAYGO S:$D(NURDIC("S")) DIC("S")=NURDIC("S") S:$D(NURDIC("DR")) DIC("DR")=NURDIC("DR") S:$D(NURLAY) DLAYGO=NURLAY K NURLAY
I +Y'>0 W:DIC(0)["Q" $C(7)," ??" G READ:DIC(0)["A",Q
S X="`"_+Y,NUR=+Y
S:$D(NURDIC("W")) DIC("W")=NURDIC("W") S DIC="^NURSF(211.4,",DIC(0)=$S(NURDIC(0)["E":"E",1:"")_"IL" D ^DIC I +Y'>0 S DA=NUR,DIK="^SC(" D ^DIK W:NURDIC["Q" $C(7)," ??" G READ:NURDIC(0)["A"
Q I $D(NURDICR) K DICR S DICR=NURDICR,%X="NURDICR(",%Y="DICR(" D %XY^%RCR
K DIC S DIC=NURDIC I $D(NURDIC)\10 S NUR="" F NUR(0)=0:0 S NUR=$O(NURDIC(NUR)) Q:NUR="" S DIC(NUR)=NURDIC(NUR)
S X=NURTMX I DIC(0)["Z",+Y>0 S Y(0)=$S($D(^NURSF(211.4,+Y,0)):^(0),1:""),Y(0,0)=$S($P(Y(0),"^")="":"",$D(^SC($P(Y(0),"^"),0)):$P(^(0),"^"),1:""),Y(0,0)=$S(Y(0,0)?1"NUR ".E:$P(Y(0,0),"NUR ",2),1:Y(0,0))
K NURA,NUR,NURDIC,NURTMX,NURX,NURY,NURZ,NURDICR,NUREXIT
Q
HELP ;
S NUREXIT=0,U="^" I $$VFIELD^DILFD(211.4,.01,3) D FIELD^DID(211.4,.01,"","HELP-PROMPT","NURX"),FIELD^DID(211.4,.01,"","XECUTABLE HELP","NURY") W:$D(NURX("HELP-PROMPT")) !,NURX("HELP-PROMPT") X:$D(NURY("XECUTABLE HELP")) NURY("XECUTABLE HELP")
HP1 I X'?2"?".E S %="" W !?2,"DO YOU WANT THE ENTIRE "_$S($P(^NURSF(211.4,0),"^",4)&'$D(DIC("S")):$P(^NURSF(211.4,0),"^",4)_"-ENTRY ",1:"")_"NURSING UNIT LIST" D YN^DICN D:%=-1!(%=2) CHK Q:%=-1!(%=2) I %=0 W !?5,"ANSWER YES OR NO" G HP1
S NURA=0,NURX="NUR " W !!,"CHOOSE FROM:" F NURX(0)=0:0 S NURX=$O(^SC("B",NURX)) Q:NURX'?1"NUR ".E!NUREXIT F NURY=0:0 S NURY=$O(^SC("B",NURX,NURY)) Q:NURY'>0 F Y=0:0 S Y=$O(^NURSF(211.4,"B",NURY,Y)) Q:Y'>0 D SCR
;S X=$S(X?2"?".E:"??",1:"?"),DIC="^NURSF(211.4,",DIC(0)="EQI" D ^DIC
Q
UPS ;
R !,"'^' TO STOP ",NURZ:DTIME S NURA=0,NUREXIT=$S(NURZ="^"!'$T:1,1:0)
Q
SCR ;
S ZZ=$$EN12^NURSUT3($G(Y)),YY=$G(^NURSF(211.4,+Y,"I")) I 1
X:$D(DIC("S")) DIC("S") I $T W !?5,$P(NURX,"NUR ",2),?32,$S(YY="I":"**INACTIVE**",1:""),?50,$S($P($G(^DIC(213.9,1,0)),U,9)="Y":$E(ZZ,1,15),1:"") S NURA=NURA+1 D:NURA=10 UPS Q:NUREXIT
Q
CHK ;
S NUREXIT=1,X="",Y=""
Q
MULT ; MULTIPLE LOOKUP
K DIC S X=NURTMX,DIC(0)="E",DIC="^DIC(42,",D="B",DIC("S")="I $D(^NURSF(211.4,""C"",+Y))" D IX^DIC K DIC I +Y>0 S:$D(NURDIC("S")) DIC("S")=NURDIC("S") S X=+Y,DIC(0)="I"_$S(NURDIC(0)["E":"E",1:""),DIC="^NURSF(211.4,",D="C" D IX^DIC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURSAFLL 4125 printed Apr 09, 2024@21:24:47 Page 2
NURSAFLL ;HIRMFO/RM,MD,FT-LOOKUP FOR FILE 211.4 ;10/10/96 13:03
+1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
EN1 ; RETURNS Y=-1 IF NO SELECTION
+1 KILL DTOUT,DUOUT
SET NUREXIT=0
SET NUR=$ORDER(^DIC(40.9,"C","NU",""))
IF NUR'>0
SET Y=-1
WRITE !,$CHAR(7),"Need to add Nursing to the LOCATION TYPE (#40.9) File"
GOTO Q
+2 if '$DATA(DIC(0))!'($DATA(DIC)#2)
QUIT
+3 IF $SELECT('($DATA(X)#2):1,X="":1,1:0)&(DIC(0)'["A")
SET Y=-1
QUIT
+4 KILL Y,NURDICR
IF $DATA(DICR)
SET %Y="NURDICR("
SET %X="DICR("
DO %XY^%RCR
SET NURDICR=DICR
KILL DICR
+5 if DIC(0)'["A"
SET NURTMX=X
SET NURDIC=DIC
IF $DATA(DIC)\10
SET NUR=""
FOR NUR(0)=0:0
SET NUR=$ORDER(DIC(NUR))
if NUR=""
QUIT
SET NURDIC(NUR)=DIC(NUR)
READ ;
+1 SET X=$$EN8^NURSAFU0()
SET NURMDSW=$SELECT(X="Y":1,1:0)
+2 IF $$SITE^VASITE()'>0
WRITE *7,!?5,"Cannot identify your Primary Station Number.",!?5,"Please contact your ADPAC or IRM Support Person.",!
SET Y=-1
QUIT
+3 KILL X,DIC
if NURDIC(0)'["A"
SET X=NURTMX
SET DIC=NURDIC
IF $DATA(NURDIC)\10
SET NUR=""
FOR NUR(0)=0:0
SET NUR=$ORDER(NURDIC(NUR))
if NUR=""
QUIT
SET DIC(NUR)=NURDIC(NUR)
+4 IF DIC(0)["A"
WRITE !,$SELECT('$DATA(DIC("A")):"Select NURSING UNIT NAME: ",1:DIC("A"))_$SELECT('$DATA(DIC("B")):"",1:$SELECT(DIC("B")?1"NUR ".E:$PIECE(DIC("B"),"NUR ",2),1:DIC("B"))_"// ")
+5 IF $TEST
READ X:DTIME
if X="^"
SET DUOUT=1
if '$TEST
SET X="^"
SET DTOUT=1
if X=""&$TEST&$DATA(DIC("B"))
SET X=DIC("B")
SET NURTMX=X
IF "^"[X
SET Y=-1
GOTO Q
+6 IF X?1"?".E
DO HELP
if DIC(0)["A"
GOTO READ
GOTO Q
+7 SET DIC(0)="EI"
SET DIC="^NURSF(211.4,"
SET X=$SELECT(X=" "!(X?1"NUR ".E):X,1:"NUR "_X)
DO ^DIC
+8 IF +Y'>0
if NURDIC(0)["M"&(NURTMX'?1"NUR ".E)
DO MULT
IF +Y'>0
IF $SELECT(NURDIC(0)'["L":1,'$DATA(DLAYGO):0,DLAYGO=211.4:0,1:1)
if NURDIC(0)["Q"
WRITE $CHAR(7)," ??"
if NURDIC(0)["A"
GOTO READ
GOTO Q
+9 if +Y>0
GOTO Q
KILL NURLAY
if $DATA(DLAYGO)
SET NURLAY=DLAYGO
+10 KILL DIC
SET X=NURTMX
SET X=$SELECT(X=" "!(X?1"NUR ".E):X,X?1"""".E1"""":"""NUR "_$EXTRACT(X,2,$LENGTH(X)),1:"NUR "_X)
SET DLAYGO=44
SET DIC="^SC("
SET DIC(0)="EL"
SET DIC("W")=""
SET DIC("S")="I NUR=$P(^(0),U,22)"
+11 SET DIC("DR")="2///^S X=""Z"";2.1///^S X=""NURSING"";S:'$G(NURMDSW) Y=""@1"";3;S Y=""@2"";@1;3///^S X=""`""_+$$SITE^VASITE();@2"
+12 DO ^DIC
KILL DIC("S"),DIC("DR"),DLAYGO
if $DATA(NURDIC("S"))
SET DIC("S")=NURDIC("S")
if $DATA(NURDIC("DR"))
SET DIC("DR")=NURDIC("DR")
if $DATA(NURLAY)
SET DLAYGO=NURLAY
KILL NURLAY
+13 IF +Y'>0
if DIC(0)["Q"
WRITE $CHAR(7)," ??"
if DIC(0)["A"
GOTO READ
GOTO Q
+14 SET X="`"_+Y
SET NUR=+Y
+15 if $DATA(NURDIC("W"))
SET DIC("W")=NURDIC("W")
SET DIC="^NURSF(211.4,"
SET DIC(0)=$SELECT(NURDIC(0)["E":"E",1:"")_"IL"
DO ^DIC
IF +Y'>0
SET DA=NUR
SET DIK="^SC("
DO ^DIK
if NURDIC["Q"
WRITE $CHAR(7)," ??"
if NURDIC(0)["A"
GOTO READ
Q IF $DATA(NURDICR)
KILL DICR
SET DICR=NURDICR
SET %X="NURDICR("
SET %Y="DICR("
DO %XY^%RCR
+1 KILL DIC
SET DIC=NURDIC
IF $DATA(NURDIC)\10
SET NUR=""
FOR NUR(0)=0:0
SET NUR=$ORDER(NURDIC(NUR))
if NUR=""
QUIT
SET DIC(NUR)=NURDIC(NUR)
+2 SET X=NURTMX
IF DIC(0)["Z"
IF +Y>0
SET Y(0)=$SELECT($DATA(^NURSF(211.4,+Y,0)):^(0),1:"")
SET Y(0,0)=$SELECT($PIECE(Y(0),"^")="":"",$DATA(^SC($PIECE(Y(0),"^"),0)):$PIECE(^(0),"^"),1:"")
SET Y(0,0)=$SELECT(Y(0,0)?1"NUR ".E:$PIECE(Y(0,0),"NUR ",2),1:Y(0,0))
+3 KILL NURA,NUR,NURDIC,NURTMX,NURX,NURY,NURZ,NURDICR,NUREXIT
+4 QUIT
HELP ;
+1 SET NUREXIT=0
SET U="^"
IF $$VFIELD^DILFD(211.4,.01,3)
DO FIELD^DID(211.4,.01,"","HELP-PROMPT","NURX")
DO FIELD^DID(211.4,.01,"","XECUTABLE HELP","NURY")
if $DATA(NURX("HELP-PROMPT"))
WRITE !,NURX("HELP-PROMPT")
if $DATA(NURY("XECUTABLE HELP"))
XECUTE NURY("XECUTABLE HELP")
HP1 IF X'?2"?".E
SET %=""
WRITE !?2,"DO YOU WANT THE ENTIRE "_$SELECT($PIECE(^NURSF(211.4,0),"^",4)&'$DATA(DIC("S")):$PIECE(^NURSF(211.4,0),"^",4)_"-ENTRY ",1:"")_"NURSING UNIT LIST"
DO YN^DICN
if %=-1!(%=2)
DO CHK
if %=-1!(%=2)
QUIT
IF %=0
WRITE !?5,"ANSWER YES OR NO"
GOTO HP1
+1 SET NURA=0
SET NURX="NUR "
WRITE !!,"CHOOSE FROM:"
FOR NURX(0)=0:0
SET NURX=$ORDER(^SC("B",NURX))
if NURX'?1"NUR ".E!NUREXIT
QUIT
FOR NURY=0:0
SET NURY=$ORDER(^SC("B",NURX,NURY))
if NURY'>0
QUIT
FOR Y=0:0
SET Y=$ORDER(^NURSF(211.4,"B",NURY,Y))
if Y'>0
QUIT
DO SCR
+2 ;S X=$S(X?2"?".E:"??",1:"?"),DIC="^NURSF(211.4,",DIC(0)="EQI" D ^DIC
+3 QUIT
UPS ;
+1 READ !,"'^' TO STOP ",NURZ:DTIME
SET NURA=0
SET NUREXIT=$SELECT(NURZ="^"!'$TEST:1,1:0)
+2 QUIT
SCR ;
+1 SET ZZ=$$EN12^NURSUT3($GET(Y))
SET YY=$GET(^NURSF(211.4,+Y,"I"))
IF 1
+2 if $DATA(DIC("S"))
XECUTE DIC("S")
IF $TEST
WRITE !?5,$PIECE(NURX,"NUR ",2),?32,$SELECT(YY="I":"**INACTIVE**",1:""),?50,$SELECT($PIECE($GET(^DIC(213.9,1,0)),U,9)="Y":$EXTRACT(ZZ,1,15),1:"")
SET NURA=NURA+1
if NURA=10
DO UPS
if NUREXIT
QUIT
+3 QUIT
CHK ;
+1 SET NUREXIT=1
SET X=""
SET Y=""
+2 QUIT
MULT ; MULTIPLE LOOKUP
+1 KILL DIC
SET X=NURTMX
SET DIC(0)="E"
SET DIC="^DIC(42,"
SET D="B"
SET DIC("S")="I $D(^NURSF(211.4,""C"",+Y))"
DO IX^DIC
KILL DIC
IF +Y>0
if $DATA(NURDIC("S"))
SET DIC("S")=NURDIC("S")
SET X=+Y
SET DIC(0)="I"_$SELECT(NURDIC(0)["E":"E",1:"")
SET DIC="^NURSF(211.4,"
SET D="C"
DO IX^DIC
+2 QUIT
