- PRCSUT41 ;WISC/KMB/BGJ-UTILITY TO CREATE NEW DISTRIBUTION SCHEDULE ;7/6/89 13:17
- V ;;5.1;IFCAP;**5**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;PRCHSY=NEW 410 IRN,PRCHJ=NEW 410 ITEM MULTIPLE IRN
- ;PRCHS=OLD 410 IRN,PRCHX=OLD 410 ITEM MULTIPLE IRN
- Q:'$D(PRCHSY)!('$D(PRCHS)) Q:'$D(PRCHJ)!('$D(PRCHX)) Q:'$D(^PRCS(410,PRCHSY,0))!('$D(^PRCS(410,PRCHS,0))) Q:'$D(^PRCS(410,PRCHSY,"IT",PRCHJ,0))!('$D(^PRCS(410,PRCHS,"IT",PRCHX,0)))
- S PRCSI=0 F PRCSJ=1:1 S PRCSI=$O(^PRCS(410,PRCHS,"IT",PRCHX,2,PRCSI)) Q:PRCSI'>0 S PRCSDS=^(PRCSI,0) Q:$P(PRCSDS,U,2)'>0 Q:'$D(^PRCS(410.6,+$P(PRCSDS,U,2),0)) S PRCSDSD=^(0) D STF
- K PRCSDS,PRCSDSD,PRCSI,PRCSJ,DLAYGO
- Q
- STF S X=PRCSDSD,$P(X,U)=$P(^PRCS(410,PRCHSY,0),U)_"-"_PRCHJ_"-"_PRCSI
- S DLAYGO=410.6,DIC="^PRCS(410.6,",DIC(0)="LOXZ" D FILE^DICN K DIC Q:Y<0 S $P(^PRCS(410.6,+Y,0),U,2,7)=$P(PRCSDSD,U,2,7)
- S:'$D(^PRCS(410,PRCHSY,"IT",PRCHJ,2,0)) ^(0)="^410.212I^^"
- S ^PRCS(410,PRCHSY,"IT",PRCHJ,2,PRCSI,0)=PRCSI_U_(+Y),^PRCS(410,PRCHSY,"IT",PRCHJ,2,"B",PRCSI,PRCSI)="" S $P(^PRCS(410,PRCHSY,"IT",PRCHJ,2,0),U,3,4)=PRCSI_U_($P(^PRCS(410,PRCHSY,"IT",PRCHJ,2,0),U,4)+1)
- Q
- USEROUT ; remove user terminated by Kernel from IFCAP
- N CPT,ST,XDA,XDA1
- Q:'DA S (CPT,ST)=0,XDA=DA
- ;remove user from supply
- K ^VA(200,XDA,400)
- ; remove user from all cps
- I $D(^PRC(420,"C",XDA)) D
- .F S ST=$O(^PRC(420,"C",XDA,ST)) Q:'ST D
- ..S CPT=0 F S CPT=$O(^PRC(420,"C",XDA,ST,CPT)) Q:'CPT D
- ...S DA(2)=ST,DA(1)=CPT,DA=XDA,DIK="^PRC(420,"_DA(2)_",1,"_DA(1)_",1," D ^DIK K DIK
- ; put users on a 'don't use' array
- S ST=0 F S ST=$O(^PRC(420,"B",ST)) Q:ST="" D
- .S DA(1)=ST,DA=XDA,DIK="^PRC(411,"_DA(1)_",6," D ^DIK K DIK
- .Q:$D(^PRC(411,ST,8,XDA))
- .S:'$D(^PRC(411,ST,8,0)) ^(0)="^411.045PA^^"
- .L +^PRC(411,ST):15 Q:'$T
- .S DA(1)=ST,DIC="^PRC(411,"_DA(1)_",8,",(DA,X)=XDA,DIC(0)="X",DINUM=X D FILE^DICN
- .L -^PRC(411,ST)
- K DIC
- ;remove user from inventory system
- S X="PRCPXTRM" X ^%ZOSF("TEST") D:$T=1 TERMUSER^PRCPXTRM(DA)
- K DA Q
- USERIN ;restore terminated user to IFCAP
- N X,Y,YY,DIR,DIRUT,DUOUT,ENTRY,STA,OK
- S (ENTRY,STA,OK)=0 W !!
- S DIR(0)="P^200:EMZ",DIR("A")="Enter username",DIR("?")="Enter name in the format lastname,firstname"
- D ^DIR K DIR Q:$D(DIRUT) W !!,"You have selected ",$P(Y,"^",2) S YY=+Y
- ;
- S DIR("A")="Do you wish to reinstate this user",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR Q:$D(DIRUT) I Y=0 W !,"No action taken." G USERIN
- ;
- F S STA=$O(^PRC(420,"B",STA)) Q:STA="" I $D(^PRC(411,STA,8,"B",YY,YY)) S ENTRY=YY D
- .S DA(1)=STA,DA=ENTRY L +^PRC(411,STA,8):3 E W $C(7),!,"User is being edited by someone else and was not reinstated as an IFCAP user for station ",STA,"." Q
- .S DIK="^PRC(411,"_DA(1)_",8," D ^DIK K DIK,DIR
- .W !,"This user was reinstated as an IFCAP user for station ",STA,"."
- .S OK=1
- .L -^PRC(411,STA,8)
- I ENTRY=0 W !,"This user was never terminated from IFCAP." G USERIN
- I 'OK G USERIN
- ;
- S DIR("A")="Is this user an A&MM employee",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR Q:$D(DIRUT) I Y=1 D
- .S DIE="^VA(200,",DR="400;.135",DA=YY L +^VA(200,DA):3 E W $C(7),!,"User is being edited by someone else and was not added as an A&MM employee." Q
- .D ^DIE K DIE
- .L -^VA(200,YY) W !?5,"To edit the Signature Block printed name or title, use TBOX"
- W !! G USERIN
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSUT41 3347 printed Jan 18, 2025@03:20:23 Page 2
- PRCSUT41 ;WISC/KMB/BGJ-UTILITY TO CREATE NEW DISTRIBUTION SCHEDULE ;7/6/89 13:17
- V ;;5.1;IFCAP;**5**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;PRCHSY=NEW 410 IRN,PRCHJ=NEW 410 ITEM MULTIPLE IRN
- +3 ;PRCHS=OLD 410 IRN,PRCHX=OLD 410 ITEM MULTIPLE IRN
- +4 if '$DATA(PRCHSY)!('$DATA(PRCHS))
- QUIT
- if '$DATA(PRCHJ)!('$DATA(PRCHX))
- QUIT
- if '$DATA(^PRCS(410,PRCHSY,0))!('$DATA(^PRCS(410,PRCHS,0)))
- QUIT
- if '$DATA(^PRCS(410,PRCHSY,"IT",PRCHJ,0))!('$DATA(^PRCS(410,PRCHS,"IT",PRCHX,0)))
- QUIT
- +5 SET PRCSI=0
- FOR PRCSJ=1:1
- SET PRCSI=$ORDER(^PRCS(410,PRCHS,"IT",PRCHX,2,PRCSI))
- if PRCSI'>0
- QUIT
- SET PRCSDS=^(PRCSI,0)
- if $PIECE(PRCSDS,U,2)'>0
- QUIT
- if '$DATA(^PRCS(410.6,+$PIECE(PRCSDS,U,2),0))
- QUIT
- SET PRCSDSD=^(0)
- DO STF
- +6 KILL PRCSDS,PRCSDSD,PRCSI,PRCSJ,DLAYGO
- +7 QUIT
- STF SET X=PRCSDSD
- SET $PIECE(X,U)=$PIECE(^PRCS(410,PRCHSY,0),U)_"-"_PRCHJ_"-"_PRCSI
- +1 SET DLAYGO=410.6
- SET DIC="^PRCS(410.6,"
- SET DIC(0)="LOXZ"
- DO FILE^DICN
- KILL DIC
- if Y<0
- QUIT
- SET $PIECE(^PRCS(410.6,+Y,0),U,2,7)=$PIECE(PRCSDSD,U,2,7)
- +2 if '$DATA(^PRCS(410,PRCHSY,"IT",PRCHJ,2,0))
- SET ^(0)="^410.212I^^"
- +3 SET ^PRCS(410,PRCHSY,"IT",PRCHJ,2,PRCSI,0)=PRCSI_U_(+Y)
- SET ^PRCS(410,PRCHSY,"IT",PRCHJ,2,"B",PRCSI,PRCSI)=""
- SET $PIECE(^PRCS(410,PRCHSY,"IT",PRCHJ,2,0),U,3,4)=PRCSI_U_($PIECE(^PRCS(410,PRCHSY,"IT",PRCHJ,2,0),U,4)+1)
- +4 QUIT
- USEROUT ; remove user terminated by Kernel from IFCAP
- +1 NEW CPT,ST,XDA,XDA1
- +2 if 'DA
- QUIT
- SET (CPT,ST)=0
- SET XDA=DA
- +3 ;remove user from supply
- +4 KILL ^VA(200,XDA,400)
- +5 ; remove user from all cps
- +6 IF $DATA(^PRC(420,"C",XDA))
- Begin DoDot:1
- +7 FOR
- SET ST=$ORDER(^PRC(420,"C",XDA,ST))
- if 'ST
- QUIT
- Begin DoDot:2
- +8 SET CPT=0
- FOR
- SET CPT=$ORDER(^PRC(420,"C",XDA,ST,CPT))
- if 'CPT
- QUIT
- Begin DoDot:3
- +9 SET DA(2)=ST
- SET DA(1)=CPT
- SET DA=XDA
- SET DIK="^PRC(420,"_DA(2)_",1,"_DA(1)_",1,"
- DO ^DIK
- KILL DIK
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +10 ; put users on a 'don't use' array
- +11 SET ST=0
- FOR
- SET ST=$ORDER(^PRC(420,"B",ST))
- if ST=""
- QUIT
- Begin DoDot:1
- +12 SET DA(1)=ST
- SET DA=XDA
- SET DIK="^PRC(411,"_DA(1)_",6,"
- DO ^DIK
- KILL DIK
- +13 if $DATA(^PRC(411,ST,8,XDA))
- QUIT
- +14 if '$DATA(^PRC(411,ST,8,0))
- SET ^(0)="^411.045PA^^"
- +15 LOCK +^PRC(411,ST):15
- if '$TEST
- QUIT
- +16 SET DA(1)=ST
- SET DIC="^PRC(411,"_DA(1)_",8,"
- SET (DA,X)=XDA
- SET DIC(0)="X"
- SET DINUM=X
- DO FILE^DICN
- +17 LOCK -^PRC(411,ST)
- End DoDot:1
- +18 KILL DIC
- +19 ;remove user from inventory system
- +20 SET X="PRCPXTRM"
- XECUTE ^%ZOSF("TEST")
- if $TEST=1
- DO TERMUSER^PRCPXTRM(DA)
- +21 KILL DA
- QUIT
- USERIN ;restore terminated user to IFCAP
- +1 NEW X,Y,YY,DIR,DIRUT,DUOUT,ENTRY,STA,OK
- +2 SET (ENTRY,STA,OK)=0
- WRITE !!
- +3 SET DIR(0)="P^200:EMZ"
- SET DIR("A")="Enter username"
- SET DIR("?")="Enter name in the format lastname,firstname"
- +4 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- WRITE !!,"You have selected ",$PIECE(Y,"^",2)
- SET YY=+Y
- +5 ;
- +6 SET DIR("A")="Do you wish to reinstate this user"
- SET DIR(0)="Y"
- SET DIR("B")="YES"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- IF Y=0
- WRITE !,"No action taken."
- GOTO USERIN
- +7 ;
- +8 FOR
- SET STA=$ORDER(^PRC(420,"B",STA))
- if STA=""
- QUIT
- IF $DATA(^PRC(411,STA,8,"B",YY,YY))
- SET ENTRY=YY
- Begin DoDot:1
- +9 SET DA(1)=STA
- SET DA=ENTRY
- LOCK +^PRC(411,STA,8):3
- IF '$TEST
- WRITE $CHAR(7),!,"User is being edited by someone else and was not reinstated as an IFCAP user for station ",STA,"."
- QUIT
- +10 SET DIK="^PRC(411,"_DA(1)_",8,"
- DO ^DIK
- KILL DIK,DIR
- +11 WRITE !,"This user was reinstated as an IFCAP user for station ",STA,"."
- +12 SET OK=1
- +13 LOCK -^PRC(411,STA,8)
- End DoDot:1
- +14 IF ENTRY=0
- WRITE !,"This user was never terminated from IFCAP."
- GOTO USERIN
- +15 IF 'OK
- GOTO USERIN
- +16 ;
- +17 SET DIR("A")="Is this user an A&MM employee"
- SET DIR(0)="Y"
- SET DIR("B")="YES"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- IF Y=1
- Begin DoDot:1
- +18 SET DIE="^VA(200,"
- SET DR="400;.135"
- SET DA=YY
- LOCK +^VA(200,DA):3
- IF '$TEST
- WRITE $CHAR(7),!,"User is being edited by someone else and was not added as an A&MM employee."
- QUIT
- +19 DO ^DIE
- KILL DIE
- +20 LOCK -^VA(200,YY)
- WRITE !?5,"To edit the Signature Block printed name or title, use TBOX"
- End DoDot:1
- +21 WRITE !!
- GOTO USERIN
- +22 QUIT