PRCAI217 ;ALB/CXW - PRCA*4.5*217 POST-INIT ROUTINE
;;4.5;Accounts Receivable;**217**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
EN ;convert the data stored in the global DISV(DUZ,"RCDPRPLM") file to the
;AR USER CUSTOMIZE file (#342.3).
;^RC(342.3,da,0)=screen/options
;^RC(342.3,da,1,da(1),0)=duz^selection^device
;
N RCDUZ,RCSNOPT,RCREC,RCSEL,RCDEV,U,DA,X,DIC,DIE,DR
W !
W "PRCA*4.5*217 Post Install......",!
W "Converting the data stored in the ^DISV(DUZ,""RCDPRPLM"") global to",!
W "the AR USER CUSTOMIZE file (#342.3)."
S RCDUZ=0,U="^"
F S RCDUZ=$O(^DISV(RCDUZ)) Q:'RCDUZ I $D(^DISV(RCDUZ,"RCDPRPLM")) D
.S RCSNOPT=""
.L +^DISV(RCDUZ,"RCDPRPLM"):5
.F S RCSNOPT=$O(^DISV(RCDUZ,"RCDPRPLM",RCSNOPT)) Q:RCSNOPT="" D
..S RCREC=$G(^DISV(RCDUZ,"RCDPRPLM",RCSNOPT))
..I '$D(^RC(342.3,"B",RCSNOPT)) D
...K DD,DO,DIC("DR") S DIC="^RC(342.3,",DIC(0)="",X=RCSNOPT
...D FILE^DICN
..S RCSEL=$S(RCSNOPT="215REPORT":"",1:$P(RCREC,U))
..S RCDEV=$S(RCSNOPT="RECEIPT":$P(RCREC,U,2),RCSNOPT="215REPORT":$P(RCREC,U),1:"")
..S DA(1)=$O(^RC(342.3,"B",RCSNOPT,0))
..;if new then add entry
..I '$D(^RC(342.3,DA(1),1,"B",RCDUZ)) D Q
...S DIC(0)="",DIC("P")=$P(^DD(342.3,1,0),U,2)
...S DIC="^RC(342.3,"_DA(1)_",1,"
...S X=RCDUZ
...S DIC("DR")="1////"_RCSEL_";2////"_RCDEV
...K DD,DO D FILE^DICN
...;
..;if existing then edit entry
..S DA=$O(^RC(342.3,DA(1),1,"B",RCDUZ,0)),DR=".01////"_RCDUZ_";1////"_RCSEL_";2////"_RCDEV
..S DIE="^RC(342.3,"_DA(1)_",1," D ^DIE
.W "."
.L -^DISV(RCDUZ,"RCDPRPLM")
W "Done!"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAI217 1614 printed Dec 13, 2024@01:40:07 Page 2
PRCAI217 ;ALB/CXW - PRCA*4.5*217 POST-INIT ROUTINE
+1 ;;4.5;Accounts Receivable;**217**;Mar 20, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
EN ;convert the data stored in the global DISV(DUZ,"RCDPRPLM") file to the
+1 ;AR USER CUSTOMIZE file (#342.3).
+2 ;^RC(342.3,da,0)=screen/options
+3 ;^RC(342.3,da,1,da(1),0)=duz^selection^device
+4 ;
+5 NEW RCDUZ,RCSNOPT,RCREC,RCSEL,RCDEV,U,DA,X,DIC,DIE,DR
+6 WRITE !
+7 WRITE "PRCA*4.5*217 Post Install......",!
+8 WRITE "Converting the data stored in the ^DISV(DUZ,""RCDPRPLM"") global to",!
+9 WRITE "the AR USER CUSTOMIZE file (#342.3)."
+10 SET RCDUZ=0
SET U="^"
+11 FOR
SET RCDUZ=$ORDER(^DISV(RCDUZ))
if 'RCDUZ
QUIT
IF $DATA(^DISV(RCDUZ,"RCDPRPLM"))
Begin DoDot:1
+12 SET RCSNOPT=""
+13 LOCK +^DISV(RCDUZ,"RCDPRPLM"):5
+14 FOR
SET RCSNOPT=$ORDER(^DISV(RCDUZ,"RCDPRPLM",RCSNOPT))
if RCSNOPT=""
QUIT
Begin DoDot:2
+15 SET RCREC=$GET(^DISV(RCDUZ,"RCDPRPLM",RCSNOPT))
+16 IF '$DATA(^RC(342.3,"B",RCSNOPT))
Begin DoDot:3
+17 KILL DD,DO,DIC("DR")
SET DIC="^RC(342.3,"
SET DIC(0)=""
SET X=RCSNOPT
+18 DO FILE^DICN
End DoDot:3
+19 SET RCSEL=$SELECT(RCSNOPT="215REPORT":"",1:$PIECE(RCREC,U))
+20 SET RCDEV=$SELECT(RCSNOPT="RECEIPT":$PIECE(RCREC,U,2),RCSNOPT="215REPORT":$PIECE(RCREC,U),1:"")
+21 SET DA(1)=$ORDER(^RC(342.3,"B",RCSNOPT,0))
+22 ;if new then add entry
+23 IF '$DATA(^RC(342.3,DA(1),1,"B",RCDUZ))
Begin DoDot:3
+24 SET DIC(0)=""
SET DIC("P")=$PIECE(^DD(342.3,1,0),U,2)
+25 SET DIC="^RC(342.3,"_DA(1)_",1,"
+26 SET X=RCDUZ
+27 SET DIC("DR")="1////"_RCSEL_";2////"_RCDEV
+28 KILL DD,DO
DO FILE^DICN
+29 ;
End DoDot:3
QUIT
+30 ;if existing then edit entry
+31 SET DA=$ORDER(^RC(342.3,DA(1),1,"B",RCDUZ,0))
SET DR=".01////"_RCDUZ_";1////"_RCSEL_";2////"_RCDEV
+32 SET DIE="^RC(342.3,"_DA(1)_",1,"
DO ^DIE
End DoDot:2
+33 WRITE "."
+34 LOCK -^DISV(RCDUZ,"RCDPRPLM")
End DoDot:1
+35 WRITE "Done!"
+36 QUIT
