- ASUMKBPS ; IHS/ITSC/LMH -UPDATE ISSUE BOOK MASTER ;
- ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
- ;This routine is a utility which is invoked to update the Issue Book
- ;Master file. The Issue Book master file is used to capture
- ;statistics concerning Issues.
- I $G(ASUT(ASUT,"B/O"))="B"&$G(ASUT(ASUT,"FPN"))="N" Q
- I $E(ASUT("TRCD"))=0 D
- .S ASUMK("E#","STA")=$G(ASUT(ASUT,"PT","STA"))
- E D
- .S ASUMK("E#","STA")=$G(ASUMS("E#","STA"))
- S ASUMK("E#","REQ")=ASUT(ASUT,"PT","REQ")
- D STA^ASUMKBIO(ASUMK("E#","STA")) ;Lookup STA in Issue Book Master
- I Y<1 D Q:$D(DDSERROR)
- .I Y=0 D
- ..D ADDSTA^ASUMKBIO(ASUMK("E#","STA")) ;Add STA to Issue Book master
- ..I Y<0 D
- ...N Z S Z="Error adding STA : "_ASUMK("E#","STA")_" to YTD DATA -RC : "_Y W *7 D HLP^ASUJHELP(.Z) S DDSERROR=1 ;DFM P1 9/1/98
- .E D
- ..N Z S Z="Error finding STA : "_ASUMK("E#","STA")_" for YTD DATA -RC : "_Y W *7 D HLP^ASUJHELP(.Z) S DDSERROR=2 ;DFM P1 9/1/98
- D REQ^ASUMKBIO(ASUMK("E#","REQ")) ;Lookup REQ in Issue Book master
- I Y<1 D Q:$D(DDSERROR)
- .I Y=0 D
- ..D ADDREQ^ASUMKBIO(ASUMK("E#","REQ")) ;Add REQ to Issue Book master
- ..I Y<0 D
- ...N Z S Z="Error adding REQ : "_ASUMK("E#","REQ")_" to YTD DATA -RC : "_Y W *7 D HLP^ASUJHELP(.Z) S DDSERROR=3 ;DFM P1 9/1/98
- .E D
- ..N Z S Z="Error finding REQ : "_ASUMK("E#","REQ")_" for YTD DATA -RC : "_Y W *7 D HLP^ASUJHELP(.Z) S DDSERROR=4 ;DFM P1 9/1/98
- I ASUT("TYPE")=7 D
- .S ASUMX("E#","IDX")="99999999"
- E D
- .D IDX^ASUMKBIO(ASUMX("E#","IDX")) ;Lookup IDX in Issue Book master
- I Y<1 D Q:$D(DDSERROR)
- .I Y=0 D
- ..D ADDIDX^ASUMKBIO(ASUMK("E#","IDX")) ;Add IDX to Issue Book master
- ..I Y<0 D
- ...N Z S Z="Error adding IDX : "_ASUMK("E#","IDX")_" to YTD DATA -RC : "_Y W *7 D HLP^ASUJHELP(.Z) S DDSERROR=5 ;DFM P1 9/1/98
- .E D
- ..N Z S Z="Error finding IDX : "_ASUMK("E#","IDX")_" for YTD DATA -RC : "_Y W *7 D HLP^ASUJHELP(.Z) S DDSERROR=6 ;DFM P1 9/1/98
- D READ^ASUMKBIO ;Read Issue Book master into variables
- I ASUT("TRCD")="5B" D
- .S ASUMK("ULQTY")=$S(ASUT(ASUT,"ULVQTY")=0:"",1:ASUT(ASUT,"ULVQTY"))
- .S ASUMK("PULQTY")=1
- E D
- .S ASUV("MO")=+($P(ASUT(ASUT,"VOU"),"-",2))
- .Q:ASUV("MO")']""
- .I $E(ASUT("TRCD"),2)?1A D
- ..S ASUMK(ASUV("MO"),"DOC")=$G(ASUMK(ASUV("MO"),"DOC"))-1
- ..S ASUMK(ASUV("MO"),"QTY")=$G(ASUMK(ASUV("MO"),"QTY"))-ASUT(ASUT,"QTY","ISS")
- ..S ASUMK("CFY","VAL")=$G(ASUMK("CFY","VAL"))-(ASUT(ASUT,"VAL"))
- .E D
- ..I ASUT("TRCD")'="31" D
- ...S ASUMK(ASUV("MO"),"DOC")=$G(ASUMK(ASUV("MO"),"DOC"))+1
- ..S ASUMK(ASUV("MO"),"QTY")=$G(ASUMK(ASUV("MO"),"QTY"))+ASUT(ASUT,"QTY","ISS")
- ..S ASUMK("CFY","VAL")=$G(ASUMK("CFY","VAL"))+(ASUT(ASUT,"VAL"))
- D EN1^ASUMKBIO
- Q
- CLMO ;EP ;CLEAR MONTH
- S ASUMK("MO")=ASUP("MO")+1 S:ASUMK("MO")=13 ASUMK("MO")=1
- CLSM ;EP ;CLEAR PREVIOUSLY SELECTED MONTH
- S (ASUMK("E#","STA"),ASUMK("E#","REQ"),ASUMK("E#","IDX"))=0
- F S ASUMK("E#","STA")=$O(^ASUMK(ASUMK("E#","STA"))) Q:ASUMK("E#","STA")'?1N.N D
- .F S ASUMK("E#","REQ")=$O(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"))) Q:ASUMK("E#","REQ")'?1N.N D
- ..F S ASUMK("E#","IDX")=$O(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,ASUMK("E#","IDX"))) Q:ASUMK("E#","IDX")'?1N.N D
- ...D READ^ASUMKBIO
- ...S ASUMK(ASUMK("MO"),"DOC")=""
- ...S ASUMK(ASUMK("MO"),"QTY")=""
- ...S ASUMK("NOKL")=1 D EN1^ASUMKBIO
- ..S ASUMK("E#","IDX")=0
- .S ASUMK("E#","REQ")=0,ASUMK("E#","IDX")=0
- K ASUMK
- Q
- CLYR ;EP; CLEAR YEARLY
- S ASUP("CKY")=+$G(ASUP("CKY"))
- D DATE^ASUUDATE,TIME^ASUUDATE
- S ASURX="W !,""S.A.M.S. Beginning of Year Update Procedure begun "_ASUK("DT","TIME")_"""" D ^ASUUPLOG
- I ASUP("CKY")=0 S ASUP("CKY")=1 D SETSY^ASUCOSTS
- I ASUP("CKY")=1 D ASUYPSYR G:ASUP("HLT") DONE S ASUP("CKY")=2 D SETSY^ASUCOSTS
- I ASUP("CKY")=2 D ASUKPSYR G:ASUP("HLT") DONE S ASUP("CKY")=3 D SETSY^ASUCOSTS
- I ASUP("CKY")=3 D G:ASUP("HLT") DONE S ASUP("CKY")=4 D SETSY^ASUCOSTS
- .S ASURX="W !,""Clearing Transaction History Files""" D ^ASUUPLOG
- .D EN2^ASU0PURG
- I ASUP("CKY")=4 D
- .S ASUU("E#")=""
- .F S ASUU("E#")=$O(^ASUR1(ASUU("E#"))) Q:ASUU("E#")="" Q:ASUU("E#")="B" F ASUC("TR")=4,5,7,8,10,11,13,14,16,17,19,20 S $P(^ASUR1(ASUU("E#"),0),U,ASUC("TR"))=0
- .K ASU
- .S ASUP("CKY")=5 D SETSY^ASUCOSTS
- Q:$G(ASUP("HLT"))
- D TIME^ASUUDATE
- S ASURX="W !,""S.A.M.S. Beginning of Year Update Procedure ended "_ASUK("DT","TIME")_"""" D ^ASUUPLOG
- Q
- DONE ;
- S ASUP("HLT")=1
- Q
- ASUYPSYR ;
- S ASURX="W !,""Clearing Year to Date Issue Data""" D ^ASUUPLOG
- S (ASUMY("E#","REQ"),ASUMY("E#","SSA"),ASUMY("E#","ACC"))=0
- F S ASUMY("E#","REQ")=$O(^ASUMY(ASUMY("E#","REQ"))) Q:ASUMY("E#","REQ")'?1N.N K ^ASUMY(ASUMY("E#","REQ"))
- Q
- F S ASUMY("E#","REQ")=$O(^ASUMY(ASUMY("E#","REQ"))) Q:ASUMY("E#","REQ")'?1N.N D
- .F S ASUMY("E#","SSA")=$O(^ASUMY(ASUMY("E#","REQ"),1,ASUMY("E#","SSA"))) Q:ASUMY("E#","SSA")'?1N.N D
- ..F S ASUMY("E#","ACC")=$O(^ASUMY(ASUMY("E#","REQ"),1,ASUMY("E#","SSA"),1,ASUMY("E#","ACC"))) Q:ASUMY("E#","ACC")'?1N.N S ASUQ(1)="" D
- ...D READ^ASUMYDIO
- ...F S ASUQ(1)=$O(ASUMY("CMO",ASUQ(1))) Q:ASUQ(1)']"" S ASUQ(2)="" D
- ....F S ASUQ(2)=$O(ASUMY("CMO",ASUQ(1),ASUQ(2))) Q:ASUQ(2)']"" D
- .....S ASUMY("CMO",ASUQ(1),ASUQ(2))=""
- ...F S ASUQ(1)=$O(ASUMY("YTD",ASUQ(1))) Q:ASUQ(1)']"" S ASUQ(2)="" D
- ....F S ASUQ(2)=$O(ASUMY("YTD",ASUQ(1),ASUQ(2))) Q:ASUQ(2)']"" D
- .....S ASUMY("YTD",ASUQ(1),ASUQ(2))=""
- ...S (ASUMY("ISO","LI"),ASUMY("ISP","LI"),ASUMY("B/O","LI"),ASUMY("QTYADJ","LI"))=""
- ...S ASUMY("NOKL")=1 D WRITY^ASUMYDIO
- ..S ASUMY("E#","ACC")=0
- .S ASUMY("E#","SSA")=0
- K DR,DIE,DA,ASUMY,ASU
- Q
- ASUKPSYR ;
- S ASURX="W !,""Clearing Issue Book Master""" D ^ASUUPLOG
- S ASUMK("E#","STA")=0
- F S ASUMK("E#","STA")=$O(^ASUMK(ASUMK("E#","STA"))) Q:ASUMK("E#","STA")'?1N.N D
- .S ASUMK("E#","REQ")=0
- .F S ASUMK("E#","REQ")=$O(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"))) Q:ASUMK("E#","REQ")'?1N.N D
- ..S ASUMK("E#","IDX")=0
- ..F S ASUMK("E#","IDX")=$O(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,ASUMK("E#","IDX"))) Q:ASUMK("E#","IDX")'?1N.N D
- ...D READ^ASUMKBIO
- ...S ASUMK("PPY","VAL")=ASUMK("PFY","VAL")
- ...S ASUMK("PFY","VAL")=ASUMK("CFY","VAL")
- ...S ASUMK("CFY","VAL")=""
- ...S ASUMK("NOKL")=1 D EN1^ASUMKBIO
- K ASUMK
- Q
- ASUMKBPS ; IHS/ITSC/LMH -UPDATE ISSUE BOOK MASTER ;
- +1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
- +2 ;This routine is a utility which is invoked to update the Issue Book
- +3 ;Master file. The Issue Book master file is used to capture
- +4 ;statistics concerning Issues.
- +5 IF $GET(ASUT(ASUT,"B/O"))="B"&$GET(ASUT(ASUT,"FPN"))="N"
- QUIT
- +6 IF $EXTRACT(ASUT("TRCD"))=0
- Begin DoDot:1
- +7 SET ASUMK("E#","STA")=$GET(ASUT(ASUT,"PT","STA"))
- End DoDot:1
- +8 IF '$TEST
- Begin DoDot:1
- +9 SET ASUMK("E#","STA")=$GET(ASUMS("E#","STA"))
- End DoDot:1
- +10 SET ASUMK("E#","REQ")=ASUT(ASUT,"PT","REQ")
- +11 ;Lookup STA in Issue Book Master
- DO STA^ASUMKBIO(ASUMK("E#","STA"))
- +12 IF Y<1
- Begin DoDot:1
- +13 IF Y=0
- Begin DoDot:2
- +14 ;Add STA to Issue Book master
- DO ADDSTA^ASUMKBIO(ASUMK("E#","STA"))
- +15 IF Y<0
- Begin DoDot:3
- +16 ;DFM P1 9/1/98
- NEW Z
- SET Z="Error adding STA : "_ASUMK("E#","STA")_" to YTD DATA -RC : "_Y
- WRITE *7
- DO HLP^ASUJHELP(.Z)
- SET DDSERROR=1
- End DoDot:3
- End DoDot:2
- +17 IF '$TEST
- Begin DoDot:2
- +18 ;DFM P1 9/1/98
- NEW Z
- SET Z="Error finding STA : "_ASUMK("E#","STA")_" for YTD DATA -RC : "_Y
- WRITE *7
- DO HLP^ASUJHELP(.Z)
- SET DDSERROR=2
- End DoDot:2
- End DoDot:1
- IF $DATA(DDSERROR)
- QUIT
- +19 ;Lookup REQ in Issue Book master
- DO REQ^ASUMKBIO(ASUMK("E#","REQ"))
- +20 IF Y<1
- Begin DoDot:1
- +21 IF Y=0
- Begin DoDot:2
- +22 ;Add REQ to Issue Book master
- DO ADDREQ^ASUMKBIO(ASUMK("E#","REQ"))
- +23 IF Y<0
- Begin DoDot:3
- +24 ;DFM P1 9/1/98
- NEW Z
- SET Z="Error adding REQ : "_ASUMK("E#","REQ")_" to YTD DATA -RC : "_Y
- WRITE *7
- DO HLP^ASUJHELP(.Z)
- SET DDSERROR=3
- End DoDot:3
- End DoDot:2
- +25 IF '$TEST
- Begin DoDot:2
- +26 ;DFM P1 9/1/98
- NEW Z
- SET Z="Error finding REQ : "_ASUMK("E#","REQ")_" for YTD DATA -RC : "_Y
- WRITE *7
- DO HLP^ASUJHELP(.Z)
- SET DDSERROR=4
- End DoDot:2
- End DoDot:1
- IF $DATA(DDSERROR)
- QUIT
- +27 IF ASUT("TYPE")=7
- Begin DoDot:1
- +28 SET ASUMX("E#","IDX")="99999999"
- End DoDot:1
- +29 IF '$TEST
- Begin DoDot:1
- +30 ;Lookup IDX in Issue Book master
- DO IDX^ASUMKBIO(ASUMX("E#","IDX"))
- End DoDot:1
- +31 IF Y<1
- Begin DoDot:1
- +32 IF Y=0
- Begin DoDot:2
- +33 ;Add IDX to Issue Book master
- DO ADDIDX^ASUMKBIO(ASUMK("E#","IDX"))
- +34 IF Y<0
- Begin DoDot:3
- +35 ;DFM P1 9/1/98
- NEW Z
- SET Z="Error adding IDX : "_ASUMK("E#","IDX")_" to YTD DATA -RC : "_Y
- WRITE *7
- DO HLP^ASUJHELP(.Z)
- SET DDSERROR=5
- End DoDot:3
- End DoDot:2
- +36 IF '$TEST
- Begin DoDot:2
- +37 ;DFM P1 9/1/98
- NEW Z
- SET Z="Error finding IDX : "_ASUMK("E#","IDX")_" for YTD DATA -RC : "_Y
- WRITE *7
- DO HLP^ASUJHELP(.Z)
- SET DDSERROR=6
- End DoDot:2
- End DoDot:1
- IF $DATA(DDSERROR)
- QUIT
- +38 ;Read Issue Book master into variables
- DO READ^ASUMKBIO
- +39 IF ASUT("TRCD")="5B"
- Begin DoDot:1
- +40 SET ASUMK("ULQTY")=$SELECT(ASUT(ASUT,"ULVQTY")=0:"",1:ASUT(ASUT,"ULVQTY"))
- +41 SET ASUMK("PULQTY")=1
- End DoDot:1
- +42 IF '$TEST
- Begin DoDot:1
- +43 SET ASUV("MO")=+($PIECE(ASUT(ASUT,"VOU"),"-",2))
- +44 IF ASUV("MO")']""
- QUIT
- +45 IF $EXTRACT(ASUT("TRCD"),2)?1A
- Begin DoDot:2
- +46 SET ASUMK(ASUV("MO"),"DOC")=$GET(ASUMK(ASUV("MO"),"DOC"))-1
- +47 SET ASUMK(ASUV("MO"),"QTY")=$GET(ASUMK(ASUV("MO"),"QTY"))-ASUT(ASUT,"QTY","ISS")
- +48 SET ASUMK("CFY","VAL")=$GET(ASUMK("CFY","VAL"))-(ASUT(ASUT,"VAL"))
- End DoDot:2
- +49 IF '$TEST
- Begin DoDot:2
- +50 IF ASUT("TRCD")'="31"
- Begin DoDot:3
- +51 SET ASUMK(ASUV("MO"),"DOC")=$GET(ASUMK(ASUV("MO"),"DOC"))+1
- End DoDot:3
- +52 SET ASUMK(ASUV("MO"),"QTY")=$GET(ASUMK(ASUV("MO"),"QTY"))+ASUT(ASUT,"QTY","ISS")
- +53 SET ASUMK("CFY","VAL")=$GET(ASUMK("CFY","VAL"))+(ASUT(ASUT,"VAL"))
- End DoDot:2
- End DoDot:1
- +54 DO EN1^ASUMKBIO
- +55 QUIT
- CLMO ;EP ;CLEAR MONTH
- +1 SET ASUMK("MO")=ASUP("MO")+1
- IF ASUMK("MO")=13
- SET ASUMK("MO")=1
- CLSM ;EP ;CLEAR PREVIOUSLY SELECTED MONTH
- +1 SET (ASUMK("E#","STA"),ASUMK("E#","REQ"),ASUMK("E#","IDX"))=0
- +2 FOR
- SET ASUMK("E#","STA")=$ORDER(^ASUMK(ASUMK("E#","STA")))
- IF ASUMK("E#","STA")'?1N.N
- QUIT
- Begin DoDot:1
- +3 FOR
- SET ASUMK("E#","REQ")=$ORDER(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ")))
- IF ASUMK("E#","REQ")'?1N.N
- QUIT
- Begin DoDot:2
- +4 FOR
- SET ASUMK("E#","IDX")=$ORDER(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,ASUMK("E#","IDX")))
- IF ASUMK("E#","IDX")'?1N.N
- QUIT
- Begin DoDot:3
- +5 DO READ^ASUMKBIO
- +6 SET ASUMK(ASUMK("MO"),"DOC")=""
- +7 SET ASUMK(ASUMK("MO"),"QTY")=""
- +8 SET ASUMK("NOKL")=1
- DO EN1^ASUMKBIO
- End DoDot:3
- +9 SET ASUMK("E#","IDX")=0
- End DoDot:2
- +10 SET ASUMK("E#","REQ")=0
- SET ASUMK("E#","IDX")=0
- End DoDot:1
- +11 KILL ASUMK
- +12 QUIT
- CLYR ;EP; CLEAR YEARLY
- +1 SET ASUP("CKY")=+$GET(ASUP("CKY"))
- +2 DO DATE^ASUUDATE
- DO TIME^ASUUDATE
- +3 SET ASURX="W !,""S.A.M.S. Beginning of Year Update Procedure begun "_ASUK("DT","TIME")_""""
- DO ^ASUUPLOG
- +4 IF ASUP("CKY")=0
- SET ASUP("CKY")=1
- DO SETSY^ASUCOSTS
- +5 IF ASUP("CKY")=1
- DO ASUYPSYR
- IF ASUP("HLT")
- GOTO DONE
- SET ASUP("CKY")=2
- DO SETSY^ASUCOSTS
- +6 IF ASUP("CKY")=2
- DO ASUKPSYR
- IF ASUP("HLT")
- GOTO DONE
- SET ASUP("CKY")=3
- DO SETSY^ASUCOSTS
- +7 IF ASUP("CKY")=3
- Begin DoDot:1
- +8 SET ASURX="W !,""Clearing Transaction History Files"""
- DO ^ASUUPLOG
- +9 DO EN2^ASU0PURG
- End DoDot:1
- IF ASUP("HLT")
- GOTO DONE
- SET ASUP("CKY")=4
- DO SETSY^ASUCOSTS
- +10 IF ASUP("CKY")=4
- Begin DoDot:1
- +11 SET ASUU("E#")=""
- +12 FOR
- SET ASUU("E#")=$ORDER(^ASUR1(ASUU("E#")))
- IF ASUU("E#")=""
- QUIT
- IF ASUU("E#")="B"
- QUIT
- FOR ASUC("TR")=4,5,7,8,10,11,13,14,16,17,19,20
- SET $PIECE(^ASUR1(ASUU("E#"),0),U,ASUC("TR"))=0
- +13 KILL ASU
- +14 SET ASUP("CKY")=5
- DO SETSY^ASUCOSTS
- End DoDot:1
- +15 IF $GET(ASUP("HLT"))
- QUIT
- +16 DO TIME^ASUUDATE
- +17 SET ASURX="W !,""S.A.M.S. Beginning of Year Update Procedure ended "_ASUK("DT","TIME")_""""
- DO ^ASUUPLOG
- +18 QUIT
- DONE ;
- +1 SET ASUP("HLT")=1
- +2 QUIT
- ASUYPSYR ;
- +1 SET ASURX="W !,""Clearing Year to Date Issue Data"""
- DO ^ASUUPLOG
- +2 SET (ASUMY("E#","REQ"),ASUMY("E#","SSA"),ASUMY("E#","ACC"))=0
- +3 FOR
- SET ASUMY("E#","REQ")=$ORDER(^ASUMY(ASUMY("E#","REQ")))
- IF ASUMY("E#","REQ")'?1N.N
- QUIT
- KILL ^ASUMY(ASUMY("E#","REQ"))
- +4 QUIT
- +5 FOR
- SET ASUMY("E#","REQ")=$ORDER(^ASUMY(ASUMY("E#","REQ")))
- IF ASUMY("E#","REQ")'?1N.N
- QUIT
- Begin DoDot:1
- +6 FOR
- SET ASUMY("E#","SSA")=$ORDER(^ASUMY(ASUMY("E#","REQ"),1,ASUMY("E#","SSA")))
- IF ASUMY("E#","SSA")'?1N.N
- QUIT
- Begin DoDot:2
- +7 FOR
- SET ASUMY("E#","ACC")=$ORDER(^ASUMY(ASUMY("E#","REQ"),1,ASUMY("E#","SSA"),1,ASUMY("E#","ACC")))
- IF ASUMY("E#","ACC")'?1N.N
- QUIT
- SET ASUQ(1)=""
- Begin DoDot:3
- +8 DO READ^ASUMYDIO
- +9 FOR
- SET ASUQ(1)=$ORDER(ASUMY("CMO",ASUQ(1)))
- IF ASUQ(1)']""
- QUIT
- SET ASUQ(2)=""
- Begin DoDot:4
- +10 FOR
- SET ASUQ(2)=$ORDER(ASUMY("CMO",ASUQ(1),ASUQ(2)))
- IF ASUQ(2)']""
- QUIT
- Begin DoDot:5
- +11 SET ASUMY("CMO",ASUQ(1),ASUQ(2))=""
- End DoDot:5
- End DoDot:4
- +12 FOR
- SET ASUQ(1)=$ORDER(ASUMY("YTD",ASUQ(1)))
- IF ASUQ(1)']""
- QUIT
- SET ASUQ(2)=""
- Begin DoDot:4
- +13 FOR
- SET ASUQ(2)=$ORDER(ASUMY("YTD",ASUQ(1),ASUQ(2)))
- IF ASUQ(2)']""
- QUIT
- Begin DoDot:5
- +14 SET ASUMY("YTD",ASUQ(1),ASUQ(2))=""
- End DoDot:5
- End DoDot:4
- +15 SET (ASUMY("ISO","LI"),ASUMY("ISP","LI"),ASUMY("B/O","LI"),ASUMY("QTYADJ","LI"))=""
- +16 SET ASUMY("NOKL")=1
- DO WRITY^ASUMYDIO
- End DoDot:3
- +17 SET ASUMY("E#","ACC")=0
- End DoDot:2
- +18 SET ASUMY("E#","SSA")=0
- End DoDot:1
- +19 KILL DR,DIE,DA,ASUMY,ASU
- +20 QUIT
- ASUKPSYR ;
- +1 SET ASURX="W !,""Clearing Issue Book Master"""
- DO ^ASUUPLOG
- +2 SET ASUMK("E#","STA")=0
- +3 FOR
- SET ASUMK("E#","STA")=$ORDER(^ASUMK(ASUMK("E#","STA")))
- IF ASUMK("E#","STA")'?1N.N
- QUIT
- Begin DoDot:1
- +4 SET ASUMK("E#","REQ")=0
- +5 FOR
- SET ASUMK("E#","REQ")=$ORDER(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ")))
- IF ASUMK("E#","REQ")'?1N.N
- QUIT
- Begin DoDot:2
- +6 SET ASUMK("E#","IDX")=0
- +7 FOR
- SET ASUMK("E#","IDX")=$ORDER(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,ASUMK("E#","IDX")))
- IF ASUMK("E#","IDX")'?1N.N
- QUIT
- Begin DoDot:3
- +8 DO READ^ASUMKBIO
- +9 SET ASUMK("PPY","VAL")=ASUMK("PFY","VAL")
- +10 SET ASUMK("PFY","VAL")=ASUMK("CFY","VAL")
- +11 SET ASUMK("CFY","VAL")=""
- +12 SET ASUMK("NOKL")=1
- DO EN1^ASUMKBIO
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 KILL ASUMK
- +14 QUIT
