- NURSUT0 ;HIRMFO/MD,RM,FT-NURS STAFF FILE EDIT UTILITY ; 1/17/03 2:54pm
- ;;4.0;NURSING SERVICE;**1,16,18,33,34,38**;Apr 25, 1997
- ;
- ; Reference to File #452.3 is supported by IA #1400
- ; Reference to ^PRSPC is supported by IA #1402
- ; File #200 is covered by supported reference #10060
- ;
- EN1(NURSEMP,NURSDT) ; DETERMINE IF EMPLOYEE HAS ANY ACTIVE ASSIGNMENTS
- ;VARIBLES NURSDT=TODAY, AND NURSEMP=EMPLOYEE POINTER TO FILE 200
- ;ARE PASSED INTO THE ROUTINE AND VARIBLE NURSTAT IS RETURNED=1 IF AN
- ;ACTIVE POSITION EXISTS AND NURSTAT=0 IF NO ACTIVE POSITIONS EXIST.
- ;ACTIVE POSITIONS HAVE A START DATE '>TODAY AND NO VACANCY DATE OR A
- ;VACANCY DATE '<TODAY
- S NURSTAT=0,NURSDT=$P(NURSDT,".") D
- .F NI(1)=0:0 S NI(1)=$O(^NURSF(211.8,"C",+NURSEMP,NI(1))) Q:NI(1)'>0 F NI=0:0 S NI=$O(^NURSF(211.8,"C",+NURSEMP,NI(1),NI)) Q:NI'>0 I +^NURSF(211.8,NI(1),1,NI,0)'>NURSDT&(('+$P(^(0),U,6))!(+$P(^(0),U,6)'<NURSDT)) S NURSTAT=1
- .K NURSDT,NURSEMP,NURI
- .Q
- Q $S(NURSTAT=1:1,1:0)
- EN2 ; FIND PRIMARY SERVICE POSITION
- Q:'$D(^NURSF(210,DA,0)) S ID=+^(0) Q:ID'>0 S (NOD1,NOD2,NPSPOS,NPSPOS(0),NPSPOS(1))=""
- I '($P(^NURSF(210,DA,0),U,2)="R") D EN3 G SVPOS
- I $D(^NURSF(211.8,"AE",ID)) F NURSX=0:0 S NURSX=$O(^NURSF(211.8,"AE",ID,1,NURSX)) Q:NURSX'>0 F NURSZ=0:0 S NURSZ=$O(^NURSF(211.8,"AE",ID,1,NURSX,NURSZ)) Q:NURSZ'>0 I +$G(^NURSF(211.8,NURSX,1,NURSZ,0)) D
- . S NURS("AE",(9999999-+$G(^NURSF(211.8,NURSX,1,NURSZ,0))),NURSX,NURSZ)=""
- . Q
- I $O(NURS("AE",0)) S NURSX=$O(NURS("AE",0)),NOD1=$O(NURS("AE",NURSX,0)),NOD2=$O(NURS("AE",NURSX,NOD1,0))
- SVPOS Q:'$D(^NURSF(211.8,+NOD1,1,+NOD2,0)) S NPNT=$P(^NURSF(211.8,NOD1,1,NOD2,0),U,3) S NPSPOS=$S('$D(^NURSF(211.3,NPNT,0)):"",1:$P(^(0),U)),NPSPOS(0)=NPNT,NPSPOS(1)=$S('$D(^NURSF(211.3,NPNT,0)):"",1:$P(^(0),U,5))
- S SC44DA=+$G(^NURSF(211.8,NOD1,0)),NUR2114D=$O(^NURSF(211.4,"B",SC44DA,0))
- S NPNT(1)=+$P(^NURSF(211.3,NPNT,0),U,7),NURFLAG=1
- ; GET PRODUCT LINE/FACILITY OF PRIMARY POSITION
- S NPSPOS(2)=$S(NPNT(1):$$GET1^DIQ(212.7,NPNT(1),.01,"I"),1:"")
- S (NPSPOS(3),NPSPOS(4))="" I NOD1 D
- . S NPSPOS(3)=$$EN11^NURSUT3(NOD1)
- . S NPSPOS(4)=$$EN13^NURSUT3(NOD1)
- K NURS,NURFLAG,NPI,NPNT,NPI1,ID Q
- Q
- EN3 ; SELECT FIRST ACTIVE PRIMARY ASSIGNMENT
- S (NOD1,NOD2)="",NURFLAG=0,ID=$S($P($G(^NURSF(210,+DA,0)),U):$P(^(0),U),1:"") Q:ID=""
- F NUI(1)=0:0 S NUI(1)=$O(^NURSF(211.8,"AE",ID,1,NUI(1))) Q:NUI(1)'>0!(NURFLAG=1) F NUI=0:0 S NUI=$O(^NURSF(211.8,"AE",ID,1,NUI(1),NUI)) Q:NUI'>0!(NURFLAG=1) D CHECK
- K NUI,ID
- Q
- CHECK ;
- I +$P(^NURSF(211.8,NUI(1),1,NUI,0),U)'>DT&(('+$P(^(0),U,6))!($P(^(0),U,6)'<DT)) S NOD1=NUI(1),NOD2=NUI,NOD2(1)=$P(^(0),U) S NURFLAG=1
- Q
- EN4 ;SET LOGIC FOR DE XREF OF 211.82 SUBFILE
- S:+$P(NUR,U,3) ^NURSF(211.8,"AD",X,$P(NUR,U,3),DA(1),DA)="" S:+$P(NUR,U,9) ^NURSF(211.8,"AE",X,$P(NUR,U,9),DA(1),DA)="" K NUR
- Q
- EN5 ;KILL LOGIC FOR DE XREF 0F 211.82 SUBFILE
- K:+$P(NUR,U,3) ^NURSF(211.8,"AD",X,$P(NUR,U,3),DA(1),DA) K:+$P(NUR,U,9) ^NURSF(211.8,"AE",X,$P(NUR,U,9),DA(1),DA) K NUR
- Q
- EN6 ; SELECT MULTIPLE REPORT COPIES
- W !?5,"How many copies of this report are required: 1// " R NCOPY:DTIME
- I NCOPY=U!('$T) S NURQUIT=1 Q
- S:NCOPY="" NCOPY=1 I NCOPY'=+NCOPY!(NCOPY<1)!(NCOPY>20) W !,$C(7),?5,"ANSWER WITH A NUMBER BETWEEN 1 AND 20",!! G EN6
- Q
- EN7 ; NURS DEVICE HANDLING/QUEUEING LOGIC
- K ZTSK S %ZIS="Q" S:$G(NURS132) %ZIS("B")=""
- D ^%ZIS K %ZIS K:POP IO("Q") I POP S (NUROUT,NURQUIT)=1 Q
- I IO'=IO(0),$E(IOST)="P",'$D(IO("Q")),'$D(IO("S")),IOST'["P-MESSAGE-HFS" S XQH="NURS-PRINTER QUEUE" W $C(7) D EN^XQH K XQH G EN7
- I $G(NURS132),IOM<132 D ^%ZISC W !,$C(7)," ** THIS REPORT MUST BE SENT TO A 132 COLUMN DEVICE **",! K IO("Q"),IO("C") G EN7
- I '$D(ZTDESC) S ZTDESC=$S($D(ZTRTN):ZTRTN,1:"Unknown NURSING option")
- F X="A*","B*","C*","D*","E*","F*","G*","H*","I*","J*","K*","L*","M*","N*","O*","P*","Q*","R*","S*","T*","U*","V*","W*","Y*","Z*" S ZTSAVE(X)=""
- S NURQUEUE=0 I $D(IO("Q")) K IO("Q"),IO("C") S NURQUEUE=1,ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL D ^%ZTLOAD S NURQUEUE=0 S:'$D(ZTSK) POP=1
- Q
- EN8 ; INPUT TRANSFORM FOR 2.1 & 2.5 SUBFIELDS OF FIELD 22.5
- ;OF FILE 210
- S NURS(0)=$S($D(^NURSF(210,DA(1),20,DA,0)):^(0),1:""),NURS("HELP")="DATE MUST BE "_$P("GREATER THAN DATE STARTED OR A VALID DATE ^LESS THAN DATE ENDED OR A VALID DATE ",U,NURS*10=21+1)
- S %DT(0)=+($E("-",NURS*10=21)_$P(NURS(0),U,$E(56,NURS*10=21+1)))
- S NURS(1)=$S(NURS=2.5&%DT(0)=0:1,1:0)
- K:%DT(0)=0 %DT(0) S %DT="E" D ^%DT S X=Y I Y<1 W !?5,NURS("HELP") K X,NURS Q
- S %DT(0)="-"_DT,%DT="E" D ^%DT S X=Y I Y<1 W !?5,"DATE MUST BE A CURRENT OR PAST DATE" K X,NURS Q
- I NURS(1) S $P(^NURSF(210,DA(1),20,DA,0),U,5)=X
- K %DT,NURS
- Q
- EN9 ; FIND TOUR OF DUTY FROM STAFF FILE
- D EN3^NURSUT0 S NUR=$S('$D(^NURSF(211.8,+NOD1,1,+NOD2,0)):"",1:$P(^(0),U,10)),NUR(1)=$S('$D(^NURSF(211.6,+NUR,0)):"",1:$P(^(0),U))
- K NOD1,NOD2
- Q
- EN11(D0) ; PRINT EMPLOYEE MI REVIEW GROUPS
- S VA200DA=+$G(^NURSF(210,D0,0)),SSN=$P($G(^VA(200,+VA200DA,1)),U,9),PDA=$S(SSN="":0,1:$O(^PRSPC("SSN",SSN,0)))
- I PDA>0 W !,?$S($G(EDIT)=1:0,1:9),"MI REVIEW GROUP: " F D1=0:0 S D1=$O(^PRSPC(PDA,5,D1)) Q:D1'>0 I $G(^PRSPC(PDA,5,D1,0))'="" S PRSE=+$G(^(0)) W ?$S($G(EDIT)=1:18,1:26),$P($G(^PRSE(452.3,+PRSE,0)),U) W:$O(^PRSPC(PDA,5,D1)) !
- Q
- EN12(DA) ; PRINT EMPLOYEE SALARY
- N X,Y,DM,D0,DE,DC,DG,DI,DIC,DIEL,DIFLD,DK,DQ,DP,DH,DL,DIE,DR
- S SDA=DA,(PDA,XXX)=0,DA200=+$G(^NURSF(210,DA,0)),SSN=$P($G(^VA(200,+DA200,1)),U,9) S:$G(SSN)'="" PDA=$O(^PRSPC("SSN",SSN,0))
- I PDA>0 S XXX=$P($G(^PRSPC(PDA,0)),U,29),Y=$P($G(^(0)),U,28) D:+Y>0 D^DIQ S $P(XXX,U,2)=Y S DA=SDA K PDA,SSN,DA200
- Q XXX
- EN13(DA) ; LATEST PROMOTION DATE
- N X,Y,DM,D0,DE,DC,DG,DI,DIC,DIEL,DIFLD,DK,DQ,DP,DH,DL,DIE,DR
- S SDA=DA,Z=$O(^NURSF(210,DA,9,"AA",0)),Y=(9999999-Z) D:+Y>0 D^DIQ S XXX=Y
- Q XXX
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURSUT0 5760 printed Jan 18, 2025@03:23:31 Page 2
- NURSUT0 ;HIRMFO/MD,RM,FT-NURS STAFF FILE EDIT UTILITY ; 1/17/03 2:54pm
- +1 ;;4.0;NURSING SERVICE;**1,16,18,33,34,38**;Apr 25, 1997
- +2 ;
- +3 ; Reference to File #452.3 is supported by IA #1400
- +4 ; Reference to ^PRSPC is supported by IA #1402
- +5 ; File #200 is covered by supported reference #10060
- +6 ;
- EN1(NURSEMP,NURSDT) ; DETERMINE IF EMPLOYEE HAS ANY ACTIVE ASSIGNMENTS
- +1 ;VARIBLES NURSDT=TODAY, AND NURSEMP=EMPLOYEE POINTER TO FILE 200
- +2 ;ARE PASSED INTO THE ROUTINE AND VARIBLE NURSTAT IS RETURNED=1 IF AN
- +3 ;ACTIVE POSITION EXISTS AND NURSTAT=0 IF NO ACTIVE POSITIONS EXIST.
- +4 ;ACTIVE POSITIONS HAVE A START DATE '>TODAY AND NO VACANCY DATE OR A
- +5 ;VACANCY DATE '<TODAY
- +6 SET NURSTAT=0
- SET NURSDT=$PIECE(NURSDT,".")
- Begin DoDot:1
- +7 FOR NI(1)=0:0
- SET NI(1)=$ORDER(^NURSF(211.8,"C",+NURSEMP,NI(1)))
- if NI(1)'>0
- QUIT
- FOR NI=0:0
- SET NI=$ORDER(^NURSF(211.8,"C",+NURSEMP,NI(1),NI))
- if NI'>0
- QUIT
- IF +^NURSF(211.8,NI(1),1,NI,0)'>NURSDT&(('+$PIECE(^(0),U,6))!(+$PIECE(^(0),U,6)'<NURSDT))
- SET NURSTAT=1
- +8 KILL NURSDT,NURSEMP,NURI
- +9 QUIT
- End DoDot:1
- +10 QUIT $SELECT(NURSTAT=1:1,1:0)
- EN2 ; FIND PRIMARY SERVICE POSITION
- +1 if '$DATA(^NURSF(210,DA,0))
- QUIT
- SET ID=+^(0)
- if ID'>0
- QUIT
- SET (NOD1,NOD2,NPSPOS,NPSPOS(0),NPSPOS(1))=""
- +2 IF '($PIECE(^NURSF(210,DA,0),U,2)="R")
- DO EN3
- GOTO SVPOS
- +3 IF $DATA(^NURSF(211.8,"AE",ID))
- FOR NURSX=0:0
- SET NURSX=$ORDER(^NURSF(211.8,"AE",ID,1,NURSX))
- if NURSX'>0
- QUIT
- FOR NURSZ=0:0
- SET NURSZ=$ORDER(^NURSF(211.8,"AE",ID,1,NURSX,NURSZ))
- if NURSZ'>0
- QUIT
- IF +$GET(^NURSF(211.8,NURSX,1,NURSZ,0))
- Begin DoDot:1
- +4 SET NURS("AE",(9999999-+$GET(^NURSF(211.8,NURSX,1,NURSZ,0))),NURSX,NURSZ)=""
- +5 QUIT
- End DoDot:1
- +6 IF $ORDER(NURS("AE",0))
- SET NURSX=$ORDER(NURS("AE",0))
- SET NOD1=$ORDER(NURS("AE",NURSX,0))
- SET NOD2=$ORDER(NURS("AE",NURSX,NOD1,0))
- SVPOS if '$DATA(^NURSF(211.8,+NOD1,1,+NOD2,0))
- QUIT
- SET NPNT=$PIECE(^NURSF(211.8,NOD1,1,NOD2,0),U,3)
- SET NPSPOS=$SELECT('$DATA(^NURSF(211.3,NPNT,0)):"",1:$PIECE(^(0),U))
- SET NPSPOS(0)=NPNT
- SET NPSPOS(1)=$SELECT('$DATA(^NURSF(211.3,NPNT,0)):"",1:$PIECE(^(0),U,5))
- +1 SET SC44DA=+$GET(^NURSF(211.8,NOD1,0))
- SET NUR2114D=$ORDER(^NURSF(211.4,"B",SC44DA,0))
- +2 SET NPNT(1)=+$PIECE(^NURSF(211.3,NPNT,0),U,7)
- SET NURFLAG=1
- +3 ; GET PRODUCT LINE/FACILITY OF PRIMARY POSITION
- +4 SET NPSPOS(2)=$SELECT(NPNT(1):$$GET1^DIQ(212.7,NPNT(1),.01,"I"),1:"")
- +5 SET (NPSPOS(3),NPSPOS(4))=""
- IF NOD1
- Begin DoDot:1
- +6 SET NPSPOS(3)=$$EN11^NURSUT3(NOD1)
- +7 SET NPSPOS(4)=$$EN13^NURSUT3(NOD1)
- End DoDot:1
- +8 KILL NURS,NURFLAG,NPI,NPNT,NPI1,ID
- QUIT
- +9 QUIT
- EN3 ; SELECT FIRST ACTIVE PRIMARY ASSIGNMENT
- +1 SET (NOD1,NOD2)=""
- SET NURFLAG=0
- SET ID=$SELECT($PIECE($GET(^NURSF(210,+DA,0)),U):$PIECE(^(0),U),1:"")
- if ID=""
- QUIT
- +2 FOR NUI(1)=0:0
- SET NUI(1)=$ORDER(^NURSF(211.8,"AE",ID,1,NUI(1)))
- if NUI(1)'>0!(NURFLAG=1)
- QUIT
- FOR NUI=0:0
- SET NUI=$ORDER(^NURSF(211.8,"AE",ID,1,NUI(1),NUI))
- if NUI'>0!(NURFLAG=1)
- QUIT
- DO CHECK
- +3 KILL NUI,ID
- +4 QUIT
- CHECK ;
- +1 IF +$PIECE(^NURSF(211.8,NUI(1),1,NUI,0),U)'>DT&(('+$PIECE(^(0),U,6))!($PIECE(^(0),U,6)'<DT))
- SET NOD1=NUI(1)
- SET NOD2=NUI
- SET NOD2(1)=$PIECE(^(0),U)
- SET NURFLAG=1
- +2 QUIT
- EN4 ;SET LOGIC FOR DE XREF OF 211.82 SUBFILE
- +1 if +$PIECE(NUR,U,3)
- SET ^NURSF(211.8,"AD",X,$PIECE(NUR,U,3),DA(1),DA)=""
- if +$PIECE(NUR,U,9)
- SET ^NURSF(211.8,"AE",X,$PIECE(NUR,U,9),DA(1),DA)=""
- KILL NUR
- +2 QUIT
- EN5 ;KILL LOGIC FOR DE XREF 0F 211.82 SUBFILE
- +1 if +$PIECE(NUR,U,3)
- KILL ^NURSF(211.8,"AD",X,$PIECE(NUR,U,3),DA(1),DA)
- if +$PIECE(NUR,U,9)
- KILL ^NURSF(211.8,"AE",X,$PIECE(NUR,U,9),DA(1),DA)
- KILL NUR
- +2 QUIT
- EN6 ; SELECT MULTIPLE REPORT COPIES
- +1 WRITE !?5,"How many copies of this report are required: 1// "
- READ NCOPY:DTIME
- +2 IF NCOPY=U!('$TEST)
- SET NURQUIT=1
- QUIT
- +3 if NCOPY=""
- SET NCOPY=1
- IF NCOPY'=+NCOPY!(NCOPY<1)!(NCOPY>20)
- WRITE !,$CHAR(7),?5,"ANSWER WITH A NUMBER BETWEEN 1 AND 20",!!
- GOTO EN6
- +4 QUIT
- EN7 ; NURS DEVICE HANDLING/QUEUEING LOGIC
- +1 KILL ZTSK
- SET %ZIS="Q"
- if $GET(NURS132)
- SET %ZIS("B")=""
- +2 DO ^%ZIS
- KILL %ZIS
- if POP
- KILL IO("Q")
- IF POP
- SET (NUROUT,NURQUIT)=1
- QUIT
- +3 IF IO'=IO(0)
- IF $EXTRACT(IOST)="P"
- IF '$DATA(IO("Q"))
- IF '$DATA(IO("S"))
- IF IOST'["P-MESSAGE-HFS"
- SET XQH="NURS-PRINTER QUEUE"
- WRITE $CHAR(7)
- DO EN^XQH
- KILL XQH
- GOTO EN7
- +4 IF $GET(NURS132)
- IF IOM<132
- DO ^%ZISC
- WRITE !,$CHAR(7)," ** THIS REPORT MUST BE SENT TO A 132 COLUMN DEVICE **",!
- KILL IO("Q"),IO("C")
- GOTO EN7
- +5 IF '$DATA(ZTDESC)
- SET ZTDESC=$SELECT($DATA(ZTRTN):ZTRTN,1:"Unknown NURSING option")
- +6 FOR X="A*","B*","C*","D*","E*","F*","G*","H*","I*","J*","K*","L*","M*","N*","O*","P*","Q*","R*","S*","T*","U*","V*","W*","Y*","Z*"
- SET ZTSAVE(X)=""
- +7 SET NURQUEUE=0
- IF $DATA(IO("Q"))
- KILL IO("Q"),IO("C")
- SET NURQUEUE=1
- SET ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
- DO ^%ZTLOAD
- SET NURQUEUE=0
- if '$DATA(ZTSK)
- SET POP=1
- +8 QUIT
- EN8 ; INPUT TRANSFORM FOR 2.1 & 2.5 SUBFIELDS OF FIELD 22.5
- +1 ;OF FILE 210
- +2 SET NURS(0)=$SELECT($DATA(^NURSF(210,DA(1),20,DA,0)):^(0),1:"")
- SET NURS("HELP")="DATE MUST BE "_$PIECE("GREATER THAN DATE STARTED OR A VALID DATE ^LESS THAN DATE ENDED OR A VALID DATE ",U,NURS*10=21+1)
- +3 SET %DT(0)=+($EXTRACT("-",NURS*10=21)_$PIECE(NURS(0),U,$EXTRACT(56,NURS*10=21+1)))
- +4 SET NURS(1)=$SELECT(NURS=2.5&%DT(0)=0:1,1:0)
- +5 if %DT(0)=0
- KILL %DT(0)
- SET %DT="E"
- DO ^%DT
- SET X=Y
- IF Y<1
- WRITE !?5,NURS("HELP")
- KILL X,NURS
- QUIT
- +6 SET %DT(0)="-"_DT
- SET %DT="E"
- DO ^%DT
- SET X=Y
- IF Y<1
- WRITE !?5,"DATE MUST BE A CURRENT OR PAST DATE"
- KILL X,NURS
- QUIT
- +7 IF NURS(1)
- SET $PIECE(^NURSF(210,DA(1),20,DA,0),U,5)=X
- +8 KILL %DT,NURS
- +9 QUIT
- EN9 ; FIND TOUR OF DUTY FROM STAFF FILE
- +1 DO EN3^NURSUT0
- SET NUR=$SELECT('$DATA(^NURSF(211.8,+NOD1,1,+NOD2,0)):"",1:$PIECE(^(0),U,10))
- SET NUR(1)=$SELECT('$DATA(^NURSF(211.6,+NUR,0)):"",1:$PIECE(^(0),U))
- +2 KILL NOD1,NOD2
- +3 QUIT
- EN11(D0) ; PRINT EMPLOYEE MI REVIEW GROUPS
- +1 SET VA200DA=+$GET(^NURSF(210,D0,0))
- SET SSN=$PIECE($GET(^VA(200,+VA200DA,1)),U,9)
- SET PDA=$SELECT(SSN="":0,1:$ORDER(^PRSPC("SSN",SSN,0)))
- +2 IF PDA>0
- WRITE !,?$SELECT($GET(EDIT)=1:0,1:9),"MI REVIEW GROUP: "
- FOR D1=0:0
- SET D1=$ORDER(^PRSPC(PDA,5,D1))
- if D1'>0
- QUIT
- IF $GET(^PRSPC(PDA,5,D1,0))'=""
- SET PRSE=+$GET(^(0))
- WRITE ?$SELECT($GET(EDIT)=1:18,1:26),$PIECE($GET(^PRSE(452.3,+PRSE,0)),U)
- if $ORDER(^PRSPC(PDA,5,D1))
- WRITE !
- +3 QUIT
- EN12(DA) ; PRINT EMPLOYEE SALARY
- +1 NEW X,Y,DM,D0,DE,DC,DG,DI,DIC,DIEL,DIFLD,DK,DQ,DP,DH,DL,DIE,DR
- +2 SET SDA=DA
- SET (PDA,XXX)=0
- SET DA200=+$GET(^NURSF(210,DA,0))
- SET SSN=$PIECE($GET(^VA(200,+DA200,1)),U,9)
- if $GET(SSN)'=""
- SET PDA=$ORDER(^PRSPC("SSN",SSN,0))
- +3 IF PDA>0
- SET XXX=$PIECE($GET(^PRSPC(PDA,0)),U,29)
- SET Y=$PIECE($GET(^(0)),U,28)
- if +Y>0
- DO D^DIQ
- SET $PIECE(XXX,U,2)=Y
- SET DA=SDA
- KILL PDA,SSN,DA200
- +4 QUIT XXX
- EN13(DA) ; LATEST PROMOTION DATE
- +1 NEW X,Y,DM,D0,DE,DC,DG,DI,DIC,DIEL,DIFLD,DK,DQ,DP,DH,DL,DIE,DR
- +2 SET SDA=DA
- SET Z=$ORDER(^NURSF(210,DA,9,"AA",0))
- SET Y=(9999999-Z)
- if +Y>0
- DO D^DIQ
- SET XXX=Y
- +3 QUIT XXX